perm filename MAINPR.SAI[PNT,HE]15 blob
sn#458153 filedate 1979-07-12 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00030 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 initial declarations and global variables
C00006 00003 ! facilities: error messages,syntax explanations,error,abort1
C00012 00004 ! parsing procedures
C00013 00005 ! display, input/output procedures
C00016 00006 ! display, input/output procedures - UPDATE, ARROW, Readcode
C00022 00007 ! symbol table: check,checktot,ensym,delsym,newsym,oldsym,addsymused,delsymused,delsymref
C00032 00008 ! symbol table: mk_pr, mk_rec, mk_sym
C00039 00009 ! symbol table: nwr,dcdsym,unlink,linkfr
C00046 00010 ! symbol table: control,insertion
C00052 00011 ! symbol table: killtree,killvar,reset
C00055 00012 ! assignment instruction
C00057 00013 ! tree operations: affixcode,unfixcode
C00060 00014 ! tree operations: copycode,copy,copy_tree
C00065 00015 ! arm interactions: read_pos,readarm,frasg,arm_check
C00068 00016 ! arm interactions: fconstructproc
C00072 00017 ! cmonproc
C00073 00018 ! arm motions: moveproc
C00082 00019 ! system facilities: editcode,renmcode
C00087 00020 ! parse procedures: affixproc,defineproc,unfixproc
C00093 00021 ! parse procedures: opclproc,copyproc
C00099 00022 ! parse procedures: declproc,simpledeclproc,arraydeclproc,procdeclproc,returnproc
C00115 00023 ! parse procedures: deleteproc,editproc,printproc,exitproc
C00119 00024 ! parse procedures: other, readwristproc,setbaseproc,wristproc
C00126 00025 ! pdp 10 procedures: readproc,renmproc,writeproc
C00129 00026 ! pdp 10 procedures: notavailproc,display procedures,message procedures
C00132 00027 ! debugging procedures: bailcall, ddtcall
C00134 00028 ! beginproc,endproc,ifproc,forproc,whileproc,doproc
C00138 00029 ! parse
C00150 00030 ! main program
C00153 ENDMK
C⊗;
comment initial declarations and global variables;
DEFINE $MAINPR=TRUE ;
DEFINE #NOFUNCT=TRUE; COMMENT ELIMINATE FUNCTIONS IN THIS VERSION;
REQUIRE 300 STRING_PDL;REQUIRE 1000 SYSTEM_PDL;
REQUIRE 10000 STRING_SPACE;
REQUIRE "HEADER.SAI" SOURCE_FILE;
IFC #DEBUG THENC
REQUIRE "PRINTX.HDR[AL,HE]" SOURCE_FILE;
! FOR PRINTING OUT RECORDS ;
! BAIL BUG REQUIRES FOLLOWING DUMMY PROCEDURE;
PROCEDURE BAIL_ANAMOLY;
BEGIN PRINTX(3); RECPRN(F_WRLD);TBLKSUPPRESS(NULL);SETRPM(0,0); END;
ENDC
LABEL MAINL; ! used by abort procedures to go to the top level;
LABEL DONEPOINTY; ! used to exit;
DEFINE II=0;
DEFINE MAKEOP(OPNUM,OPNAM)"[]"=
[ REDEFINE II = II + 2 ;
DEFINE OPNUM = II ; ];
REQUIRE "INTOPS.SAI" SOURCE_FILE;
REQUIRE "OPDEC2.SAI" SOURCE_FILE;
PRESET_WITH NULL,"SCALAR","VECTOR","ROT","TRANS","FRAME","MACRO","FUNCTION";
INTERNAL STRING ARRAY $DTYPE[0:7];
REQUIRE "MOVE.DEF[PNT,HE]" SOURCE_FILE;
! ****** flag to indicate if compile or interpret ********* ;
INTEGER $COMPILE; ! 0 for interp, >0 compile;
RPTR(EXPR$)$PCODE; ! pcodes for the unevaluated expressions;
IFC #DEBUG THENC INTEGER #PPCODE; ENDC
! facilities: error messages,syntax explanations,error,abort1;
INTEGER $HELP; ! used by error;
! error messages for syntactic errors;
PRESET_WITH
"--→ ; ",
"--→ , ",
"--→ . ",
"--→ [ ",
"--→ ] ",
"--→ ( ",
"--→ ) ",
"--→ + ",
"--→ * ",
"--→ ALONG ",
"--→ BY ",
"--→ INTO ",
"--→ REL ",
"--→ ROT ",
"--→ TO ",
"--→ TRANS ",
"--→ WRT ",
"--→ XHAT or YHAT or ZHAT ",
"--→ YARM or BARM ",
"--→ YHAND or BHAND ",
"--→ INPUT after ↑, ↓, ∨, ∧, <, >",
"--→ identifier ",
"--→ number ",
"--→ file name ",
"--→ arithmetic operator ",
"required ←--",
"--→ error in explicit ",
"vector ←--",
"rotation ←--",
"frame ←--",
"--→ affix_type is wrong ←--",
"--→ wrong identifier or wrong number ←--",
"--→ unrecognized instruction ←--",
"| ",
"VECTOR required after DISTANCE",
"--→ undeclared identifier ";
INTERNAL STRING ARRAY $SYNMSG[0:35];
! error messages used for semantic errors;
! the first messages cannot be moved in another position because they
are referred to using the type of the variables(#SC,#VT,#RT,@TR,@FR);
PRESET_WITH
" scalar not existent ",
" vector not existent ",
" rotation not existent ",
" trans not existent ",
" frame not existent ",
" is not scalar nor vector nor rotation ",
" object not existent ",
" out of symbol table, delete some variables and try again",
" cannot be moved ",
" already defined symbol ",
" dismatching of types ",
" affixed frame ",
" reading on arm required ",
" instruction not executed",
" is a POINTY defined variable or constant and cannot be changed";
INTERNAL STRING ARRAY $SEMSG[0:14];
INTERNAL simple procedure esc_I;
$esc_I←true;
INTERNAL PROCEDURE ESC_P;
BEGIN
define ttyset = "'047000400121";
quick_code
hrroi 1,['004000000120]; comment [004000,,"P"];
ttyset 1, ; ! this last stuff does an esc-P;
end;
END;
PROCEDURE BRK_N;
BEGIN
define ttyset = "'047000400121";
quick_code
hrroi 1,['004000000516]; comment [004000,,400+"N"];
ttyset 1, ; ! this last stuff does an BRK-N;
end;
END;
! called after syntax error. If required gives explanation of the error;
INTERNAL PROCEDURE ERROR(STRING ERR1,ERR2(NULL));
BEGIN
STRING ANSWER;
INTEGER I,J;
I ← LENGTH($CLINR);
J ← LENGTH($CLNE);
PRINT($CLNE[1 TO J-I]&LF&$CLINR,CRLF);
PRINT (ERR1,ERR2,CRLF);
ifc false thenc to temporarily destroy
PRINT(" ",TOKEN," ",$CLINR,IFC #HELP THENC "(? for more explanation)"
ELSEC CRLF ENDC);
IFC #HELP THENC
ANSWER←INCHRW;IF ANSWER=CR THEN INCHRW;
OUTSTR(CRLF);
IF ANSWER="?" THEN HLPMSG($HELP); ! if required gives explanations;
ENDC
endc IFC #DISPL THENC
IF DEVICE≠DSK_X THEN $ALLOW←0; ! while reading display is not updated;
ENDC
ESC_P;
LODED($CLNE&CR); ! so it is possible to correct the command;
$CLINR←NULL; STOKEN←FALSE;
GO TO MAINL; ! goes to the main loop;
END;
! called after unrecoverable semantic error;
INTERNAL PROCEDURE ABORT1(STRING NAME,ERROR(NULL));
BEGIN
PRINT (NAME,ERROR,CRLF);
IFC #DISPL THENC
IF DEVICE≠DSK_X THEN $ALLOW←0; ! while reading display is not updated;
ENDC
! *** PRINT("* ");ESC_P;
LODED($CLNE&CR); ! so it is possible to correct the command;
$CLINR←NULL; STOKEN←FALSE;
GO TO MAINL; ! goes to the main loop;
END;
INTERNAL PROCEDURE CHKESC_I;
IF $ESC_I THEN
BEGIN
MTYDEVSTACK;
PRINT("
<ESCAPE> I termination
");
$ESC_I←FALSE; ENABLE(15); ! reset it again;
GOTO MAINL;
END;
! parsing procedures;
! INTERNAL STRING OLDOBJ; ! used for defaults;
STRING OLDCMD; ! used for defaults;
! saves important parts of last instruction, for default instructions.
Oldobj is used to pass to gettoken the value corresponding to the ⊗;
SIMPLE PROCEDURE OLDSAV(STRING CMD,OBJ);
BEGIN
OLDCMD←CMD;
OLDOBJ←OBJ;
END;
! display, input/output procedures;
! called when an indefined variable is used. Tries to recover, asking
the correct name of the variable, and returns it.
(null string or <control-C> to return to the main loop);
STRING PROCEDURE RECOVER(STRING SYMB);
BEGIN "R"
STRING ANSWER;LABEL CC;
! you can change the identifier symb;
CC:
LODED(SYMB&CR);
ANSWER←INCHWL; ! reads new identifier;
IFC #OUTPT THENC
IF $OUT THEN CPRINT($TTYCH,ANSWER,CRLF);
ENDC
SYMB←SCAN(ANSWER,$ERRTAB,$BRCHR); ! eliminates blanks and checks break;
IF $BRCHR≠0 AND $BRCHR≠'40
THEN BEGIN
PRINT("break character found. Try again ");
GO TO CC; ! so... you can try again;
END
ELSE IF SYMB THEN RETURN(SYMB); ! a "good" symbol is returned;
! you want to delete the instruction being interpreted;
CLRBUF;
IFC #DISPL THENC
IF DEVICE≠DSK_X THEN $ALLOW←0; ! while reading display is not updated;
ENDC
PRINT($SEMSG[13],CRLF,"* ");
ESC_P;
GO TO MAINL; ! goes to the main loop;
END "R";
IFC #OUTPT THENC
! allows recovering if a file not available has been required
(null string or <control-C> to return to the main loop);
INTERNAL STRING PROCEDURE FRCVER(STRING FILE);
BEGIN "F"
LODED(FILE&CR);
ASKUSER;
IFC #OUTPT THENC
IF $OUT THEN CPRINT($TTYCH,$CLINR,CRLF);
ENDC
IF $CLINR
THEN RETURN(NAMEFILE)
ELSE BEGIN
CLRBUF;
IFC #DISPL THENC
IF DEVICE≠DSK_X THEN $ALLOW←0; ! while reading display is not updated;
ENDC
PRINT($SEMSG[13],CRLF,"* ");
ESC_P;
GO TO MAINL; ! goes to the main loop;
END;
END "F";
ENDC
! display, input/output procedures - UPDATE, ARROW, Readcode;
IFC ¬ #ARROW THENC
INTERNAL SIMPLE PROCEDURE ARROW; ;
ENDC
IFC #DISPL THENC
INTEGER MDISPLAY; ! display mode;
DEFINE TABLE_DISPLAY=0,
TYPE_DISPLAY=1,
SYMBOL_DISPLAY=2,
NO_DISPLAY=3;
RCLASS SYMBOL_LIST(RPTR(SYMBOL_LIST)NEXT;RPTR(SYMBOL)PTR);
RPTR(SYMBOL_LIST) DISPLAY_LIST;
INTEGER TDISPLAY;
BOOLEAN NDISPLAY;
PROCEDURE DPYELM(STRING S);
OUTDPW(
"########################### SELECTED VARIABLES ############################"
&crlf&S&crlf&
"###########################################################################",
-3,-2);
PROCEDURE DPYVAR(INTEGER VARTYPE);
IF NOT $DISPLAYLIST[VARTYPE] THEN
OUTDPW(
("************************* CURRENT "&$DTYPE[VARTYPE]&"S ***********************************************")
[1 TO 74]&crlf&($DISPLAYLIST[VARTYPE]←DPY_STRING(VARTYPE))&
"***************************************************************************"
,-3,-3);
PROCEDURE DPYSYMS;
BEGIN STRING S;
RPTR(SYMBOL)SYM;
RPTR(SYMBOL_LIST)SYL;
SYL←DISPLAY_LIST;
S←NULL;
WHILE SYL≠NULL_RECORD
DO BEGIN
S←S&CVSSYM(SYMBOL_LIST:PTR[SYL])&CRLF;
SYL←SYMBOL_LIST:NEXT[SYL];
END;
DPYELM(S);
END;
SIMPLE STRING PROCEDURE DEFAULT;
RETURN(" "&OLDCMD&CRLF&" "&OLDOBJ&CRLF);
! update the display (if $ALLOW=0);
INTERNAL PROCEDURE UPDATE;
BEGIN INTEGER I;
IF $ALLOW>0 THEN RETURN;
CASE MDISPLAY OF
BEGIN
[TABLE_DISPLAY]
BEGIN
DPYDRAW;
FOR I←#SC,#VT,#TR,#RT,#FR DO
IF NOT $DISPLAYLIST[I] THEN $DISPLAYLIST[I]←DPY_STRING(I);
IFC #OUTPT THENC IF NOT $OULST THEN $OULST←FILE_STRING;ENDC
$DFLST←DEFAULT;
OUTDPY;
DPYOUT(1);
END;
[NO_DISPLAY]
IF NDISPLAY THEN
BEGIN
OUTDPW(
"**************************** P O I N T Y **********************************
DISPLAY SUPPRESSED; TYPE REDISPLAY TO GET BACK DISPLAY TABLE
TYPE DISPLAY SCALARS TO DISPLAY SCALARS
****************************************************************************
",-3,-2); NDISPLAY←FALSE;
END;
[TYPE_DISPLAY]
DPYVAR(TDISPLAY);
[SYMBOL_DISPLAY]
DPYSYMS
END;
ESC_P;
END;
ENDC
IFC #OUTPT THENC
! these procedures used to read from a file are here and not in
the input/output module becuase the READEXEC procedure calls
the PARSE procedure for each instruction;
! the above comment is no longer true, since READEXEC no longer
exists. However, they should be shifted to the input/output module
when some rational means to keep track of I/0 is settled upon.
I think what is wanted is a file record that it used to keep
all the information related to each file ;
INTERNAL PROCEDURE READCODE(STRING FID; BOOLEAN ECHO(FALSE));
BEGIN
PUSHDEVSTACK;
OPEN($INPCH←GETCHAN,"DSK",0,3,0,1000,$BRCHR,$EOF);
LOOKUP($INPCH,FID,$EOF);
WHILE $EOF
DO BEGIN
PRINT("enter failed");
FID←FRCVER(FID);
LOOKUP($INPCH,FID,$EOF);
END;
IFC #DISPL THENC $ALLOW←$ALLOW+1; IF ECHO THEN DPYFREE; $SCLST←NULL; ! to force update; ENDC
DEVICE←DSK_X;
NEWFILE←TRUE; FILEPRINT←ECHO;
END;
CLEANUP FCLOSE;
ELSEC
INTERNAL PROCEDURE UPDATE;;
ENDC
! called after reading ?. Gives some information, erasing the display;
IFC #HELP THENC
SIMPLE PROCEDURE HELPREQUEST;
BEGIN "H"
IFC #DISPL THENC DPYFREE;ENDC
! reads the comand after ?, if there is;
! $TAIL←SCAN($LINE,$SCNTAB,$BRCHR);
! HLPDO($TAIL); ! in HELP.SAI[1,MLG];
hlpmsg($help);
ASKUSER;
HLPDO($clinr);
$clinr←$clne←null;
IFC #DISPL THENC UPDATE;ENDC
END "H";
ENDC
! symbol table: check,checktot,ensym,delsym,newsym,oldsym,addsymused,delsymused,delsymref;
INTERNAL RPTR(FRAME) PROCEDURE GTFRAME(INTEGER LEVOFF,#DIM; INTEGER ARRAY DIM;
RPTR(SYMBOL)S);
BEGIN
RPTR(SYMBOL)TEMP;
IF LEVOFF=ARROFF[#FR] THEN
BEGIN
INTEGER I;
FOR I←1 STEP 1 UNTIL $ENTRY[#FR] DO
IF DIM[1]=SYMBOL:INDEX[TEMP←$YMTAB[#FR,I]] THEN
RETURN(SYMBOL:OBJECT[TEMP]);
RETURN(NULL_RECORD);
END
ELSE BEGIN "array or temporary"
RPTR(ARRAYREC)ARR;
RPTR(FRAME)TEMP;
ARR←SYMBOL:OBJECT[S];
CASE #DIM OF
BEGIN
[1] TEMP←ARRAYREC:PTR[ARR][DIM[1]];
[2] TEMP←ARRAYREC:PTR[ARR][DIM[1],DIM[2]];
[3] TEMP←ARRAYREC:PTR[ARR][DIM[1],DIM[2],DIM[3]];
[4] TEMP←ARRAYREC:PTR[ARR][DIM[1],DIM[2],DIM[3],DIM[4]];
[5] TEMP←ARRAYREC:PTR[ARR][DIM[1],DIM[2],DIM[3],DIM[4],DIM[5]]
END;
RETURN(TEMP);
END "array or temporary";
END;
! returns the symbol for given offset;
RPTR(SYMBOL) PROCEDURE CHECKOFF(INTEGER LEVOFF);
BEGIN
RPTR(SYMBOL) TEMP; INTEGER I,J;
FOR I←#SC STEP 1 UNTIL #FR DO
FOR J←1 STEP 1 UNTIL $ENTRY[I]
DO IF (TEMP←$YMTAB[I,J]) AND SYMBOL:OFFSET[TEMP]=LEVOFF
THEN RETURN(TEMP);
RETURN(NULL_RECORD);
END;
! returns number of dimensions in symbol table for the leveloffset given;
INTERNAL INTEGER PROCEDURE ARRYDIM(INTEGER LEVOFF;REFERENCE RPTR(SYMBOL) SYM);
BEGIN
SYM←NULL_RECORD;
IF LEVOFF=ARROFF[#SC] OR LEVOFF=ARROFF[#VT] OR LEVOFF=ARROFF[#RT]
OR LEVOFF=ARROFF[#TR] OR LEVOFF=ARROFF[#FR]
THEN RETURN(1)
ELSE IF SYM←CHECKOFF(LEVOFF)
THEN IF SYMBOL:ACCESS[SYM]=#SIMPLE THEN RETURN(0)
ELSE RETURN(ARRAYREC:#DIM[SYMBOL:OBJECT[SYM]])
ELSE RETURN(0);
END;
! checks if symbol symb, of type nm, is in symbol table in the class nm,
and return its pointer;
INTERNAL RPTR(SYMBOL) PROCEDURE CHECK(STRING SYMB;INTEGER NM);
BEGIN
RPTR(SYMBOL) TEMP;INTEGER IND,I;
IND←$ENTRY[NM]; ! address of last record of type nm filled;
FOR I← 1 STEP 1 UNTIL IND DO
IF (TEMP←$YMTAB[NM,I])≠NULL_RECORD AND EQU(SYMBOL:PNAME[TEMP],SYMB)
THEN RETURN(TEMP);
RETURN(NULL_RECORD); ! symbol not found;
END;
! checks if symbol symb is in symbol table, determines its class and
return its pointer;
INTERNAL RPTR(SYMBOL) PROCEDURE CHECKTOT(STRING SYMB);
BEGIN
INTEGER K;RPTR(SYMBOL)TEMP;
FOR K←#MIN STEP 1 UNTIL #MAX DO
IF (TEMP←CHECK(SYMB,K))≠NULL_RECORD
THEN RETURN(TEMP);
RETURN(NULL_RECORD); ! symbol not found;
END;
! enters the symbol symb and the pointer to its node in symbol table,
in the class nm. The record of the class SCALAR,VECTOR,ROT,TRANS or
FRAME has to be constructed before calling ENSYM;
INTEGER PROCEDURE NEW_OFFSET(INTEGER NM);
BEGIN
INTEGER I;
IF NM≠#MC THEN
IF OFFSET[CUR_OFFSET,NM]=OFFSET[MAX_OFFSET,NM] THEN ERROR("NO MORE SPACE FOR NEW SYMBOLS IN 11");
IF #SC≤NM≤#VT OR #MC≤NM≤#PR
THEN OFFSET[CUR_OFFSET,NM]←OFFSET[CUR_OFFSET,NM]+1
ELSE FOR I← 3 STEP 1 UNTIL 5 DO OFFSET[CUR_OFFSET,I]←OFFSET[CUR_OFFSET,I]+1;
RETURN(OFFSET[CUR_OFFSET,NM]);
END;
INTEGER PROCEDURE NEW_BYOFFSET;
RETURN(NEW_OFFSET(#TR));
INTERNAL RPTR(SYMBOL) PROCEDURE ENSYM(STRING SYMB;INTEGER NM;RANY VAL;
RPTR(SYMBOL)OLDREC(NULL_RECORD); INTEGER ACCESS(#SIMPLE));
BEGIN
RPTR (SYMBOL) TEMP;INTEGER IND;
IF $ENTRY[NM]≥#LTYPE
THEN ABORT1($SEMSG[7]); ! out of symbol table;
IF OLDREC THEN TEMP←OLDREC ELSE TEMP←NEW_RECORD(SYMBOL);
$YMTAB[NM,$ENTRY[NM]←$ENTRY[NM]+1]←TEMP; ! pointer to the new record in $YMTAB;
! SYMBOL:VALID[TEMP]←TRUE;
SYMBOL:TYPE[TEMP]←NM;
SYMBOL:PNAME[TEMP]←SYMB; ! pname of symbol;
SYMBOL:OBJECT[TEMP]←VAL; ! pointer to the record previously created;
IF ACCESS=#SIMPLE AND #SC≤NM≤#FR THEN
BEGIN SYMBOL:INDEX[TEMP]←NEW_OFFSET(NM);
SYMBOL:OFFSET[TEMP]←ARROFF[NM];
END
ELSE IF NM=#MC THEN SYMBOL:INDEX[TEMP]←NEW_OFFSET(NM);
RETURN(TEMP);
END;
INTERNAL PROCEDURE ENSYM$(RPTR(SYMBOL)SYM; INTEGER NM(0));
BEGIN
INTEGER IND;
IF NM=0 THEN NM←SYMBOL:TYPE[SYM]
ELSE SYMBOL:TYPE[SYM]←NM;
IF $ENTRY[NM]≥#LTYPE
THEN ABORT1($SEMSG[7]); ! out of symbol table;
$YMTAB[NM,$ENTRY[NM]←$ENTRY[NM]+1]←SYM; ! pointer to the new record in $YMTAB;
IF SYMBOL:ACCESS[SYM]=#SIMPLE AND #SC≤NM≤#FR THEN
BEGIN SYMBOL:INDEX[SYM]←NEW_OFFSET(NM);
SYMBOL:OFFSET[SYM]←ARROFF[NM];
END
ELSE IF NM=#MC THEN SYMBOL:INDEX[SYM]←NEW_OFFSET(NM);
END;
! returns a new symbol, if symb is present in $YMTAB. Id used before
inserting a new symbol in $YMTAB to be sure that a symbol with the
name has not been defined before. This procedure allows recovering;
STRING PROCEDURE NEWSYM(STRING SYMB);
BEGIN
RPTR(SYMBOL)TEMP;
! if there is a symbol with the same pname allows recovering;
WHILE (TEMP←CHECKTOT(SYMB))≠NULL_RECORD
DO BEGIN
PRINT(SYMB,$SEMSG[9]);
SYMB←RECOVER(SYMB);
END;
RETURN(SYMB);
END;
! checks if symb is present in $YMTAB and returns its pointer and its
type (using the reference variable obtype), otherwise allows recovering.
Is used when the symbol required has to be present in $YMTAB (ex.
in EDIT or RENAME instruction);
RPTR(SYMBOL) PROCEDURE OLDSYM(REFERENCE STRING SYMB;REFERENCE INTEGER OBTYPE);
BEGIN
RPTR(SYMBOL)EL;
EL←CHECKTOT(SYMB);
! if symbol is not in $YMTAB, recovering is allowed;
WHILE (EL←CHECKTOT(SYMB))=NULL_RECORD
DO BEGIN
PRINT ($SEMSG[6]);
SYMB←RECOVER(SYMB);
END;
OBTYPE←SYMBOL:TYPE[EL];
RETURN(EL);
END;
PROCEDURE DELSYM(RPTR(SYMBOL)EL);
BEGIN
INTEGER ADDRFN,I;
INTEGER OBTYPE; OBTYPE←SYMBOL:TYPE[EL];
ADDRFN← $ENTRY[OBTYPE]; ! final addr. in $YMTAB for class;
FOR I←1 STEP 1 UNTIL ADDRFN DO
IF $YMTAB[OBTYPE,I]=EL
THEN BEGIN
$YMTAB[OBTYPE,I]←$YMTAB[OBTYPE,ADDRFN];
$ENTRY[OBTYPE]←ADDRFN-1; ! move last element into hole;
! SYMBOL:VALID[EL]←FALSE;
DONE;
END;
END;
! symbol table: mk_pr, mk_rec, mk_sym;
! produces a symbol record with certain fields filled in ;
RPTR(SYMBOL)PROCEDURE MK_SYM(STRING PNAME; INTEGER TYPE;
RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME,MACRO,PROC,ARRAYREC) PTR(NULL_RECORD);
INTEGER ACCESS(#SIMPLE));
BEGIN
RPTR(SYMBOL)SYM;
SYM←NEW_RECORD(SYMBOL);
SYMBOL:PNAME[SYM]←PNAME;
SYMBOL:TYPE[SYM]←TYPE;
SYMBOL:OBJECT[SYM]←PTR;
SYMBOL:ACCESS[SYM]←ACCESS;
RETURN(SYM);
END;
RPTR(PROC)PROCEDURE MK_PR(INTEGER ARGS; STRING ARRAY ARGNAME;
INTEGER ARRAY ARGTYPE,ARGACCS,ARGDIM);
IF ARGS=0 THEN RETURN(NEW_RECORD(PROC)) ELSE
BEGIN
RPTR(PROC)E;
STRING ARRAY S[1:ARGS];
INTEGER ARRAY T,C,D[1:ARGS];
ARRTRAN(S,ARGNAME);
ARRTRAN(T,ARGTYPE);
ARRTRAN(C,ARGACCS);
ARRTRAN(D,ARGDIM);
E←NEW_RECORD(PROC);
PROC:NARGS[E]←ARGS;
MEMORY[LOCATION(PROC:ARGNAME[E])]↔MEMORY[LOCATION(S)];
MEMORY[LOCATION(PROC:ARGDIM[E])]↔MEMORY[LOCATION(D)];
MEMORY[LOCATION(PROC:ARGACCS[E])]↔MEMORY[LOCATION(C)];
MEMORY[LOCATION(PROC:ARGTYPE[E])]↔MEMORY[LOCATION(T)];
RETURN(E);
END;
IFC NOT #NOFUNCT THENC
INTERNAL RPTR(FUNCTION) PROCEDURE MK_FN(INTEGER ARGS);
BEGIN
RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME,FUNCTION) ARRAY P[0:ARGS];
STRING ARRAY S[0:ARGS]; INTEGER ARRAY I[0:ARGS];
RPTR(FUNCTION)F; F←NEW_RECORD(FUNCTION);
FUNCTION:NARGS[F]←ARGS;
MEMORY[LOCATION(FUNCTION:ARGNAME[F])]←MEMORY[LOCATION(S)];
MEMORY[LOCATION(FUNCTION:PTR[F])]←MEMORY[LOCATION(P)];
MEMORY[LOCATION(FUNCTION:ARGTYPE[F])]←MEMORY[LOCATION(I)];
MEMORY[LOCATION(I)]←
MEMORY[LOCATION(P)]←MEMORY[LOCATION(S)]←0;
RETURN(F);
END;
ENDC
INTERNAL RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME) PROCEDURE MK_REC(INTEGER TYPE);
BEGIN
RANY TEMP;
REAL ARRAY XF[1:6];
CASE TYPE OF
begin "case"
[#SC] TEMP←NEW_RECORD(SCALAR);
[#VT] TEMP←NEW_RECORD(VECTOR);
[#RT] BEGIN
TEMP←NEW_RECORD(ROT);
MEMORY[LOCATION(ROT:XF[TEMP])]←MEMORY[LOCATION(XF)];
END;
[#TR] BEGIN
TEMP←NEW_RECORD(TRANS);
MEMORY[LOCATION(TRANS:XF[TEMP])]←MEMORY[LOCATION(XF)];
END;
[#FR] BEGIN
TEMP←NEW_RECORD(FRAME);
MEMORY[LOCATION(FRAME:XF[TEMP])]←MEMORY[LOCATION(XF)];
! insert here the affixment to the world;
FRAME:HOWLINKED[TEMP]←#INDLK; ! independently;
END;
! [#MC] TEMP←NEW_RECORD(MACRO);
[#FN] TEMP←NEW_RECORD(PROC);
ELSE ERROR("PARSER ERROR, NO SUCH RECORD CLASS IN MK_REC")
end "case";
MEMORY[LOCATION(XF)]←0;
RETURN(TEMP);
END;
! compares two strings s1,s2. If they are equal returns 0
otherwise if s1 is alphabetically before s2 then
returns -1 else returns 1 ;
SIMPLE INTEGER PROCEDURE COMPEQU(STRING S1,S2);
BEGIN
INTEGER I1,I2;
IF EQU(S1,S2) THEN RETURN(0);
DO I1←LOP(S1) UNTIL I1≠(I2←LOP(S2));
IF I1>I2 THEN RETURN(-1) ELSE RETURN(1);
END;
RPTR(SYMTREE)PROCEDURE MK_SYMTREE(RPTR(SYMBOL)S);
BEGIN
RPTR(SYMTREE)E;
SYMTREE:SYM[E←NEW_RECORD(SYMTREE)]←S;
RETURN(E);
END;
RECURSIVE PROCEDURE INSRTTREE(RPTR(SYMBOL)S; RPTR(SYMTREE)STREE);
BEGIN
RPTR(SYMTREE)SS;
CASE COMPEQU(SYMBOL:PNAME[S],SYMBOL:PNAME[SYMTREE:SYM[STREE]])+1 OF
BEGIN
[-1+1] IF (SS←SYMTREE:LLINK[STREE])=NULL_RECORD
THEN SYMTREE:LLINK[STREE]←MK_SYMTREE(S)
ELSE INSRTTREE(S,SS);
[0+1] ERROR("ugh trying to insert element ");
[1+1] IF (SS←SYMTREE:RLINK[STREE])=NULL_RECORD
THEN SYMTREE:RLINK[STREE]←MK_SYMTREE(S)
ELSE INSRTTREE(S,SS)
END;
END;
PROCEDURE INSERTSYMTREE(RPTR(SYMBOL)S;RPTR(BLOCKREC)STREE);
BEGIN
IF BLOCKREC:TREE[STREE]=NULL_RECORD
THEN BLOCKREC:TREE[STREE]←MK_SYMTREE(S)
ELSE INSRTTREE(S,BLOCKREC:TREE[STREE]);
BLOCKREC:#ARGS[STREE]←BLOCKREC:#ARGS[STREE]+1;
END;
RPTR(BLOCKREC)PROCEDURE BLOCKIFY(INTEGER NARGS; RPTR(SYMBOL)ARRAY SYMARR;
RPTR(BLOCKREC)BLOCK(NULL_RECORD));
BEGIN INTEGER I;
RPTR(BLOCKREC)BLOCKPTR;
IF BLOCK THEN BLOCKPTR←BLOCK ELSE BLOCKPTR←NEW_RECORD(BLOCKREC);
FOR I←1 STEP 1 UNTIL NARGS DO
INSERTSYMTREE(SYMARR[I],BLOCKPTR);
RETURN(BLOCKPTR);
END;
RPTR(SYMBOL)RECURSIVE PROCEDURE SEARCHSYMTREE(STRING S; RPTR(SYMTREE)STREE);
IF STREE=NULL_RECORD
THEN RETURN(NULL_RECORD)
ELSE CASE COMPEQU(S,SYMBOL:PNAME[SYMTREE:SYM[STREE]]) +1 OF
BEGIN
[-1+1] RETURN(SEARCHSYMTREE(S,SYMTREE:LLINK[STREE]));
[0+1] RETURN(SYMTREE:SYM[STREE]);
[1+1] RETURN(SEARCHSYMTREE(S,SYMTREE:RLINK[STREE]))
END;
INTERNAL RPTR(SYMBOL)PROCEDURE SEARCHBLOCK(STRING S; RPTR(BLOCKREC)R);
RETURN(SEARCHSYMTREE(S,BLOCKREC:TREE[R]));
! symbol table: nwr,dcdsym,unlink,linkfr;
PROCEDURE UNLINK(RPTR(FRAME) N);
BEGIN
RPTR(FRAME) Y,E;
E←FRAME:EBRO[N];
IF (Y←FRAME:YBRO[N])≠NULL_RECORD
THEN FRAME:EBRO[Y]←E
ELSE IF FRAME:DAD[N]≠NULL_RECORD THEN FRAME:SON[FRAME:DAD[N]]←E;
IF E≠NULL_RECORD THEN FRAME:YBRO[E]←Y;
FRAME:EBRO[N]←NULL_RECORD;
FRAME:YBRO[N]←NULL_RECORD;
FRAME:DAD[N]←NULL_RECORD;
END;
BOOLEAN PROCEDURE IS_ANCESTOR(RPTR(FRAME) N,D);
BEGIN
WHILE N≠NULL_RECORD DO
IF N=D THEN RETURN(TRUE)
ELSE N←FRAME:DAD[N];
RETURN(FALSE);
END;
! sets #UP pointer structure in frame tree for N to be a child of D;
INTERNAL PROCEDURE LINKFR(RPTR(FRAME) N,D);
BEGIN
IF NOT(D=F_WRLD AND FRAME:HOWLINKED[N]=#INDLK)
THEN IF IS_ANCESTOR(D,N)
THEN ABORT1(" backwards affixment to",frame:pname[D]);
IF FRAME:DAD[N]≠NULL_RECORD THEN UNLINK(N);
IF (FRAME:EBRO[N]←FRAME:SON[D])≠NULL_RECORD THEN
FRAME:YBRO[FRAME:EBRO[N]]←N;
FRAME:YBRO[N]←NULL_RECORD;
FRAME:DAD[N]←D;
FRAME:SON[D]←N;
END;
INTERNAL RPTR(TRANS) PROCEDURE ABSLOC(RPTR(FRAME) ND);
BEGIN
IFC FALSE THENC
RPTR(TRANS) XFE;
XFE←MK_REC(4); ! SHOULD BE #TR;
ABSXF(ND,TRANS:XF[XFE]);
RETURN (XFE);
ELSEC PRINT("DUMMY ABSLOC"); RETURN(NULL_RECORD); END;
RPTR(SYMBOL)PROCEDURE NWR(STRING SYMB; INTEGER TYP);
BEGIN
RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME)VAL; RPTR(SYMBOL)TEMP;
SYMB←NEWSYM(SYMB);
VAL←MK_REC(TYP);
TEMP←ENSYM(SYMB,TYP,VAL);
IF TYP=#FR THEN BEGIN FRAME:PNAME[VAL]←SYMB;
IF TEMP≠ WORLD THEN LINKFR(VAL,F_WRLD);
FRAME:PNAME[VAL]←SYMB;
FRAME:HOWLINKED[VAL]←#INDLK;
FRAME:SYM[VAL]←TEMP;
END;
$DISPLAYLIST[TYP]←NULL;
RETURN(TEMP);
END;
! like nwr but does not insert into symbol table;
RPTR(SYMBOL)PROCEDURE NNWR(STRING SYMB; INTEGER TYP);
BEGIN
RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME)VAL; RPTR(SYMBOL)TEMP;
TEMP←MK_SYM(SYMB,TYP,VAL←MK_REC(TYP));
IF TYP=#FR THEN BEGIN
IF TEMP≠ WORLD THEN LINKFR(VAL,F_WRLD);
FRAME:PNAME[VAL]←SYMB;
FRAME:HOWLINKED[VAL]←#INDLK;
FRAME:SYM[VAL]←TEMP;
END;
RETURN(TEMP);
END;
INTERNAL RPTR(SYMBOL)PROCEDURE NWAREC(RPTR(SYMBOL)TEMP;INTEGER ARRAY LB,UB);
BEGIN
RPTR(ARRAYREC)VAL;
INTEGER TYP,ADIM;
INTEGER ASIZE,I,DATA_ST;
RPTR(ANY_CLASS)PROCEDURE NEWREC(INTEGER TYP);
BEGIN RPTR(ANY_CLASS)VAL;
VAL←MK_REC(TYP);
IF TYP=#FR THEN BEGIN
IF TEMP≠ WORLD THEN LINKFR(VAL,F_WRLD);
FRAME:PNAME[VAL]←SYMBOL:PNAME[TEMP];
FRAME:HOWLINKED[VAL]←#INDLK;
FRAME:SYM[VAL]←TEMP;
END;
RETURN(VAL);
END;
VAL←SYMBOL:OBJECT[TEMP];
TYP←SYMBOL:TYPE[TEMP];
ADIM←ARRAYREC:#DIM[VAL];
BEGIN
INTEGER ARRAY ALB,AUB[1:ADIM];
ARRBLT(ALB[1],LB[1],ADIM);
ARRBLT(AUB[1],UB[1],ADIM);
ASIZE←1;
FOR I←1 STEP 1 UNTIL ADIM
DO ASIZE←ASIZE*(UB[I]-LB[I]+1);
CASE ADIM OF
BEGIN
[1] α RPTR(ANY_CLASS)ARRAY PTR[LB[1]:UB[1]];
MEMORY[LOCATION(ARRAYREC:PTR[VAL])]↔MEMORY[LOCATION(PTR)];
β;
[2] α RPTR(ANY_CLASS)ARRAY PTR[LB[1]:UB[1],LB[2]:UB[2]];
MEMORY[LOCATION(ARRAYREC:PTR[VAL])]↔MEMORY[LOCATION(PTR)];
β;
[3] α RPTR(ANY_CLASS)ARRAY PTR[LB[1]:UB[1],LB[2]:UB[2],LB[3]:UB[3]];
MEMORY[LOCATION(ARRAYREC:PTR[VAL])]↔MEMORY[LOCATION(PTR)];
β;
[4] α RPTR(ANY_CLASS)ARRAY PTR[LB[1]:UB[1],LB[2]:UB[2],
LB[3]:UB[3],LB[4]:UB[4]];
MEMORY[LOCATION(ARRAYREC:PTR[VAL])]↔MEMORY[LOCATION(PTR)];
β;
[5] α RPTR(ANY_CLASS)ARRAY PTR[LB[1]:UB[1],LB[2]:UB[2],
LB[3]:UB[3],LB[4]:UB[4],LB[5]:UB[5]];
MEMORY[LOCATION(ARRAYREC:PTR[VAL])]↔MEMORY[LOCATION(PTR)];
β
END;
MEMORY[LOCATION(ARRAYREC:LB[VAL])]↔MEMORY[LOCATION(ALB)];
MEMORY[LOCATION(ARRAYREC:UB[VAL])]↔MEMORY[LOCATION(AUB)];
DATA_ST←MEMORY[LOCATION(ARRAYREC:PTR[VAL])]-1;
END;
FOR I←1 STEP 1 UNTIL ASIZE DO
BEGIN RANY Q; Q←NEWREC(TYP);
MEMORY[DATA_ST+I]←MEMORY[LOCATION(Q)];
END;
RETURN(TEMP);
END;
! symbol table: control,insertion;
RPTR(SYMBOL)PROCEDURE CNVRTR(RPTR(SYMBOL)EL;STRING SYMB);
BEGIN
RPTR(TRANS) TEMP;
TEMP←SYMBOL:OBJECT[EL];
DELSYM(EL);
EL←NWR(SYMB,#FR);
ARRTRAN(FRAME:XF[SYMBOL:OBJECT[EL]],TRANS:XF[TEMP]);
$FRLST←$TRLST←NULL;
RETURN(EL);
END;
! if the symbol symb is present in $YMTAB in the class OBTYPE returns
the pointer to it, otherwise allows recovering. The symbol is passed
by reference so after recovering the new symbol is sent back;
RPTR(SYMBOL) PROCEDURE BELONGS2(REFERENCE STRING SYMB;INTEGER OBTYPE);
BEGIN
RPTR(SYMBOL) EL;
EL←CHECK(SYMB,OBTYPE); ! checks if symbol is present;
WHILE EL=NULL_RECORD
DO BEGIN
IF OBTYPE=#FR
THEN BEGIN
EL←CHECK(SYMB,#TR);
IF EL
THEN BEGIN
EL←CNVRTR(EL,SYMB);
RETURN(EL);
END;
END;
PRINT($SEMSG[OBTYPE-#MIN]);
SYMB←RECOVER(SYMB); ! recover can interrupt the loop and abort;
EL←CHECK(SYMB,OBTYPE);
END;
RETURN(EL); ! returns the pointer to the symbol;
END;
INTERNAL RANY PROCEDURE BELONGS(REFERENCE STRING SYMB; INTEGER OBTYPE);
RETURN(SYMBOL:OBJECT[BELONGS2(SYMB,OBTYPE)]);
! checks if the symbol (scalar,vector or rotation) is in $YMTAB.
If not inserts it, and returns its pointer;
FORWARD RPTR(FRAME) PROCEDURE FR_INSERT (REFERENCE STRING SYMB);
RPTR(SYMBOL) PROCEDURE INSERT(STRING SYMB;INTEGER OBTYPE);
BEGIN
RPTR(SYMBOL)EL;
IF OBTYPE=#FR THEN
BEGIN RPTR(FRAME)FR1; STRING S1;
S1←SYMB;
FR1←FR_INSERT(S1);
RETURN(CHECK(S1,OBTYPE));
END;
EL←CHECK(SYMB,OBTYPE);
IF EL=NULL_RECORD THEN EL←NWR(SYMB,OBTYPE);
RETURN(EL);
END;
! returns the pointer to the frame. If the frame is not present inserts it,
otherwise checks its affixment type and asks for a confirmation if
the affixment type is not independent. In that case recovering is allowed;
RPTR(FRAME) PROCEDURE FR_INSERT (REFERENCE STRING SYMB);
BEGIN "A"
RPTR(SYMBOL) EL;
RPTR(FRAME) FRA; STRING TEMP;INTEGER LINK;
WHILE TRUE
DO BEGIN "LOOP"
EL←CHECK(SYMB,#FR); ! if while copying;
IF $HELP=14
THEN WHILE EL≠NULL_RECORD
DO BEGIN
! while copying a new frame is required.
Recovering is allowed if the frame is existent;
PRINT($SEMSG[9]);
SYMB←RECOVER(SYMB);
EL←CHECK(SYMB,#FR);
END;
IF EL=NULL_RECORD
THEN BEGIN
EL←CHECK(SYMB,#TR);
IF EL THEN EL←CNVRTR(EL,SYMB)
ELSE EL←NWR(SYMB,#FR); ! defines a new frame;
RETURN(SYMBOL:OBJECT[EL]);
END
ELSE BEGIN "C"
FRA←SYMBOL:OBJECT[EL];
LINK←FRAME:HOWLINKED[FRA];
! changing values of the frame is allowed if link is #INDLK;
IF LINK=#INDLK
THEN BEGIN
$FRLST←NULL;
RETURN(FRA);
END
ELSE BEGIN
! otherwise a confirmation is required;
PRINT(SYMB,
" affixed frame. Changing values can modify the frame tree.",CRLF,
"You can change the name ");
TEMP←RECOVER(SYMB);
! if the name of the frame is the same,
changing values is allowed;
IF EQU(TEMP ,SYMB)
THEN BEGIN
$FRLST←NULL;
RETURN(FRA);
END
ELSE SYMB←TEMP;
END;
END "C";
END "LOOP";
END "A";
! symbol table: killtree,killvar,reset;
! affixes the frame pointed by n to the frame pointed by d, as indicated
by how;
INTERNAL PROCEDURE AFX_NODE(RPTR(FRAME)N,D;INTEGER HOW);
BEGIN
LINKFR(N,D); ! sets links in frame tree;
FRAME:HOWLINKED[N]←HOW;
END;
! removes from $YMTAB all nodes in the subtrees rooted at el;
RECURSIVE PROCEDURE KILLTREE (RPTR(SYMBOL) EL);
BEGIN
RPTR(FRAME)TEMP;
TEMP←SYMBOL:OBJECT[EL];
DELSYM(EL); ! removes el from $YMTAB;
TEMP←FRAME:SON[TEMP];
WHILE TEMP≠NULL_RECORD DO
BEGIN
EL←CHECK(FRAME:PNAME[TEMP],#FR);
KILLTREE(EL);
TEMP←FRAME:EBRO[TEMP];
END;
END;
! removes the symbol from $YMTAB;
PROCEDURE KILLVAR(REFERENCE STRING VAR;BOOLEAN QUIET(FALSE));
BEGIN
RPTR (SYMBOL) EL;RPTR(FRAME)D;INTEGER OBTYPE;
IF ¬QUIET THEN EL←OLDSYM(VAR,OBTYPE)
ELSE EL←CHECKTOT(VAR);
IF EL≠NULL_RECORD THEN
IF (SYMBOL:INDEX[EL]≤OFFSET[CON_OFFSET,OBTYPE←SYMBOL:TYPE[EL]])
AND (SYMBOL:OFFSET[EL]<'404
AND #SC≤OBTYPE≤#FR OR OBTYPE=#MC)
THEN PRINT("I cannot delete ",VAR,CRLF)
ELSE BEGIN "DEL"
IF OBTYPE≠#FR
THEN DELSYM(EL)
ELSE BEGIN
RPTR(FRAME)TEMP;
TEMP←SYMBOL:OBJECT[EL];
UNLINK(TEMP); ! unfixes the frame;
KILLTREE(EL); ! deletes subtrees rooted in var;
END;
$DISPLAYLIST[OBTYPE]←NULL;
END "DEL";
END;
! the procedure deletes all the variables defined by the user. It's
called by DELETE with no arguments.;
PROCEDURE RESET;
BEGIN
INTEGER IND,TEMP;
FOR IND←#MIN STEP 1 UNTIL #MAX DO
BEGIN INTEGER K,I;
WHILE (TEMP←OFFSET[RES_OFFSET,IND])<(K←$ENTRY[IND]) DO
KILLVAR(SYMBOL:PNAME[$YMTAB[IND,K]]);
$DISPLAYLIST[IND]←NULL;
END;
END;
! assignment instruction;
! assigns to first the value of ob2. If first has not been declared
the procedure determines the type of first, according to the value
of obtype;
BOOLEAN PROCEDURE PRDECL(RPTR(SYMBOL) OB1);
RETURN((SYMBOL:OFFSET[OB1]<'400) OR
(OFFSET[PRG_OFFSET,SYMBOL:TYPE[OB1]]
<SYMBOL:INDEX[OB1]≤OFFSET[CON_OFFSET,SYMBOL:TYPE[OB1]]));
PROCEDURE ASGEX2(STRING FIRST; RPTR(EXPR$)EEE(NULL_RECORD);
RPTR(SYMBOL)OB1(NULL_RECORD));
BEGIN RPTR(EXPR$)E1; INTEGER TY;
IF EEE THEN E1←EEE ELSE E1←$$GTEXPR;
IF OB1=NULL_RECORD
THEN OB1←INSERT(FIRST,TY←EXPR$:TYPE[E1])
ELSE BEGIN
IF (TY←SYMBOL:TYPE[OB1])=#FR AND EXPR$:TYPE[E1]=#TR THEN
EXPR$:TYPE[E1]←#FR
ELSE IF TY=#TR AND EXPR$:TYPE[E1]=#FR
THEN CNVRTR(OB1,FIRST)
ELSE IF EXPR$:TYPE[E1]≠TY THEN ERROR("INCOMAPTABILE TYPE ASSIGNMENT");
END;
$PCODE←$ASGPCODE(E1,OB1);
END;
PROCEDURE ASGEX3(RPTR(EXPR$)E);
$PCODE←$AASGPCODE(E,$$GTEXPR);
! tree operations: affixcode,unfixcode ;
INTERNAL PROCEDURE UFX_NODE(RPTR(FRAME)EL1,EL2);
BEGIN
UNLINK(EL1); ! breaks links in tree;
FRAME:HOWLINKED[EL1]←#INDLK;
LINKFR(EL1,F_WRLD); ! sets new links;
END;
! affixes frame1 to frame2, as indicated by afftype;
PROCEDURE AFFIXCODE(RPTR(EXPR$)FRAME1,FRAME2; INTEGER AFFTYPE;RPTR(EXPR$)E1);
$PCODE←$AFXPCODE(FRAME1,FRAME2,AFFTYPE,E1);
! tree operations: copycode,copy,copy_tree;
RECURSIVE STRING PROCEDURE COPY_TREE(RPTR(FRAME) ND; STRING PREFIX;
REFERENCE STRING NEWNAME);
BEGIN
! copies the structure rooted at ND ;
RPTR(FRAME)KIDS;
STRING RETSTR;
STRING OLDNAME,LEAVE,ONAME;
ONAME←OLDNAME←FRAME:PNAME[ND];
! constructs the new name of the frame: if the name of the copied
frame contains an underscore, the part before it is substituted
by prefix, otherwise prefix is prefixed;
LEAVE←SCAN(OLDNAME,$DSHTAB,$BRCHR);
IF $BRCHR≠0
THEN NEWNAME←PREFIX&OLDNAME
ELSE NEWNAME←PREFIX&LEAVE;
FR_INSERT(NEWNAME); ! inserts a new frame;
KIDS←FRAME:SON[ND];
RETSTR←NEWNAME&"←"&ONAME&";";
WHILE KIDS≠NULL_RECORD DO
BEGIN
STRING NEWKID;
RETSTR←RETSTR©_TREE(KIDS,PREFIX,NEWKID);
RETSTR←RETSTR&" AFFIX "&NEWKID&" TO "&NEWNAME;
IF FRAME:HOWLINKED[KIDS]≠#RGDLK THEN
RETSTR←RETSTR&" NONRIGIDLY";
RETSTR←RETSTR&";";
KIDS←FRAME:EBRO[KIDS];
END;
RETURN(RETSTR);
END;
! copies the subtree rooted at startfr and affixes it to finalfr.
Prefix is used to build the names of the new frames;
STRING PROCEDURE PCOPY(RPTR(FRAME) STARTFR,FINALFR; STRING PREFIX);
BEGIN
STRING S,NEWROOT;
S←COPY_TREE(STARTFR,PREFIX,NEWROOT);
RETURN(S&"AFFIX "&NEWROOT&" TO "&FRAME:PNAME[FINALFR]&
" AT "&FRAME:PNAME[STARTFR]&";");
END;
! merges the subtrees under startfr as sons of finalfr. Prefix is
used to build the names of new frames;
STRING PROCEDURE PMERGE(RPTR(FRAME) STARTFR,FINALFR;STRING PREFIX);
BEGIN
STRING S,NEWROOT;
RPTR(FRAME)TEMP,BROTHER;
TEMP←FRAME:SON[STARTFR];
S←NULL;
DO BEGIN
BROTHER←FRAME:EBRO[TEMP];
S←S©_TREE(TEMP,PREFIX,NEWROOT); ! copies one subtree;
S←S&"AFFIX "&NEWROOT&" TO "&FRAME:PNAME[FINALFR]&" AT "&
FRAME:PNAME[STARTFR]&"→"&FRAME:PNAME[TEMP]&";";
TEMP←BROTHER;
END
UNTIL TEMP=NULL_RECORD;
RETURN(S);
END;
! executes copy or merge operation on frame1 and frame2. Name indicates
the required operation(copy/merge);
PROCEDURE COPYCODE(STRING NAME,FRAME1,FRAME2);
BEGIN
RPTR(FRAME) FR1,FR2;STRING PREFIX,ANSWER;
FR1←BELONGS (FRAME1,#FR); ! frame1 must be a frame;
FR2←BELONGS (FRAME2,#FR); ! frame2 must be a frame;
! chooses the prefix for the new names: if the name of frame2 contains an
underscore takes the part before it, otherwise takes the first three
characters (long names) or all the name and asks for a confirmation;
ANSWER←FRAME:PNAME[FR2];
PREFIX←SCAN(ANSWER,$DSHTAB,$BRCHR);
IF $BRCHR=0 AND
LENGTH(PREFIX)>5 THEN
PREFIX←FRAME:PNAME[FR2] [1 FOR 3];
PRINT("it's OK to prefix to the new names ");
PREFIX←RECOVER(PREFIX)&"_";
$ALLOW←$ALLOW+1; ! the matching $ALLOW←$ALLOW-1 is taken care of by ASKUSER;
IF EQU(NAME,"COPY")
THEN ASKUSER(PCOPY(FR1,FR2,PREFIX)&"UPDATE;")
ELSE ASKUSER(PMERGE(FR1,FR2,PREFIX)&"UPDATE;");
END;
! arm interactions: read_pos,readarm,frasg,arm_check;
! assigns the value of pos(pointer or arm) to the frame fra. If direct
is indicated uses it to set the rotation part;
! returns the pointer to the input device pos (arm or pointer);
RPTR (FRAME) PROCEDURE INPT_DEV(REFERENCE STRING POS);
BEGIN
RPTR(FRAME) FROM;
IF EQU(POS,"BARM")
THEN RETURN(F_BARM)
ELSE IF EQU(POS,"YARM")
THEN RETURN(F_YARM)
ELSE BEGIN
FROM←BELONGS(POS,#FR);
WHILE FROM≠F_BARM AND FROM≠F_YARM
DO BEGIN
PRINT ($SEMSG[12]);
POS←RECOVER(POS);
FROM←BELONGS (POS,#FR);
END;
RETURN(FROM);
END;
END;
! reads the position of the arm from, or of the arm with pointer;
PROCEDURE READ_DEV(RPTR(FRAME) FROM);
print("dummy call to get value of the frame");
! reads the position of the device pos (arm or pointer);
PROCEDURE INPT(REFERENCE STRING POS);
BEGIN
RPTR(FRAME)FROM;
FROM←INPT_DEV(POS);
READ_DEV(FROM);
END;
! returns the pointer to the arm affixed to obj;
RPTR(FRAME) PROCEDURE ARM_CHECK(RPTR(FRAME) OBJ);
BEGIN
RPTR(FRAME) TEMP;
TEMP←OBJ;
WHILE TEMP≠F_WRLD DO
IF EQU(FRAME:PNAME[TEMP],"BARM")
OR EQU(FRAME:PNAME[TEMP],"YARM") THEN RETURN(TEMP)
ELSE TEMP←FRAME:DAD[TEMP];
ABORT1(FRAME:PNAME[OBJ],$SEMSG[8]);
END;
! arm interactions: fconstructproc;
! reads an axis name and returns its number:
xhat=0,yhat=1,zhat=2;
INTEGER PROCEDURE INPT_AXIS(REFERENCE STRING AXIS);
BEGIN
LABEL LL;
LL: AXIS←RECOVER(AXIS);
IF EQU(AXIS[2 TO ∞],"HAT") THEN RETURN(AXIS - "X")
ELSE BEGIN
PRINT($SYNMSG[17],$SYNMSG[25],CRLF,"Try again ");
GOTO LL;
END;
END;
IFC FALSE THENC
RPTR(TRANS) ARRAY T_CSTR[1:3];
! used by CONSTRUCT instruction;
! performs a construct instruction, without arguments;
PROCEDURE FCONSTRUCTPROC;
BEGIN
RPTR(FRAME) ELF;RPTR(TRANS)XFE;INTEGER I;
RPTR(FRAME) FROM;STRING POS,ANSWER,FIRST;
RPTR(VECTOR) V1,V2,V3;
PRELOAD_WITH
"move arm to the origin of the frame"&CRLF,
"move arm to the axis ",
"move arm to the plane ";
OWN STRING ARRAY INFORM[1:3];
STRING AXIS;INTEGER F_AXIS,S_AXIS;
$ALLOW←$ALLOW+1;
GTOKEN;
IF #TOKEN≠UNDECLARED_TYPE THEN ERROR("Need undeclared token for FCONSTRUCT")
ELSE FIRST←TOKEN;
AXIS←NULL;
IF F_POINTER=NULL_RECORD
THEN PRINT("pointer is not defined cannot be used",CRLF)
ELSE POS←"POINTER";
PRINT("three positions are required",CRLF);
FOR I←1 STEP 1 UNTIL 3 DO
BEGIN
! determination of the input device required;
PRINT("position ",I," read on ");
POS←RECOVER(POS);
FROM←INPT_DEV(POS); ! checks the input device;
! determination of the positions for reading;
PRINT(INFORM[I]);
IF I=2
THEN F_AXIS←INPT_AXIS(AXIS)
ELSE IF I=3
THEN BEGIN
PRINT(AXIS," - ");
AXIS←NULL;
S_AXIS←INPT_AXIS(AXIS);
IF S_AXIS=F_AXIS THEN ABORT1($SEMSG[13]);
END;
! reading of the arm position;
PRINT("type <cr> when the arm is at the desired position");
ANSWER←INCHRW;
IF ANSWER=CR
THEN ANSWER←INCHRW
ELSE ABORT1($SEMSG[13]);
READ_DEV(FROM); ! raads the appropriate arm pos.;
T_CSTR[I]←ABSLOC(FROM);
END;
! extraction of translation part;
V1←TPOS(T_CSTR[1]);
V2←TPOS(T_CSTR[2]);
V3←TPOS(T_CSTR[3]);
XFE←VVVTR(V1,V2,V3,F_AXIS,S_AXIS);
ELF←FR_INSERT(FIRST); ! inserts the new frame;
ABSSET(ELF,XFE); ! sets the new value;
$ALLOW←$ALLOW-1;
IFC #DISPL THENC UPDATE;ENDC
END;
ENDC
! cmonproc;
ifc false thenc
RECURSIVE PROCESURE DURCM;
BEGIN
RPTR(EXPR$) EXP;
GTOKEN;
IF TOKEN≠">"≠TOKEN≠"≥" THEN ERROR("Need > or ≥ for duration cm"
EXP←$$GTSCEXPR("=")
RECURSIVE PROCEDURE ONPROC;
BEGIN
$COMPILE←$COMPILE+1;
GTOKEN;
IF EQU(TOKEN,DURATION) THEN DURCM
ELSE IF EQU(TOKEN,"FORCE") THEN FORCECM
ELSE IF EQU(TOKEN,"TORQUE") THEN TORQUECM
ELSE EXPRCM;
$COMPILE←$COMPILE-1;
END;
endc
! arm motions: moveproc;
! returns code to push offset of id on stack - type must
be the same, else does not return, unless type=0 ;
RPTR(EXPR$) PROCEDURE $$GTIDREF(INTEGER TYPE; REFERENCE RPTR(SYMBOL)SYM; STRING S);
BEGIN
RPTR(EXPR$)E;
E←IDREF(SYM);
IF TYPE≠0 AND EXPR$:TYPE[E]≠TYPE THEN
IF TYPE=#FR AND EXPR$:TYPE[E]=#TR
THEN
BEGIN STRING S1; S1←SYMBOL:PNAME[SYM];
SYM←BELONGS2(S1,#FR) END
ELSE
ERROR("Id type found does not agree with expected type in "&S);
RETURN(E);
END;
! returns a scalar expr or doesnt return at all;
RPTR(EXPR$) PROCEDURE $$GTSCEXP(STRING S);
BEGIN
RPTR(EXPR$)E;
IF EXPR$:TYPE[E←$$GTEXPR]≠#SC
THEN ERROR("Need scalar expression for ",S);
RETURN(E);
END;
! returns a frame or trans expr or doesnt return at all;
RPTR(EXPR$)PROCEDURE $$GTFREXP(STRING S);
BEGIN
RPTR(EXPR$)E;
IF EXPR$:TYPE[E←$$GTEXPR]≠#TR AND EXPR$:TYPE[E]≠#FR
THEN ERROR("Need trans or frame expression for ",S);
RETURN(E);
END;
PROCEDURE MOVEPCODE(RPTR(FRAME) MFRAME;
RPTR(EXPR$) ARRAY FDESTS; INTEGER NFDEST);
BEGIN
RPTR(SYMBOL) S1,S2; RPTR(FRAME)F1;
S1←CHECK(FRAME:PNAME[MFRAME],#FR);
S2←CHECK(FRAME:PNAME[F1←ARM_CHECK(MFRAME)],#FR);
$PCODE←$MOVEPCODE(S1,S2,FDESTS,NFDEST);
END;
! reads/exec TO <fr>+<vt>{wrt <fr>} or BY <vector>{wrt <fr>};
PROCEDURE PBYPROC;
BEGIN
RPTR(FRAME) FRAM1;RPTR(EXPR$)ARRAY FDEST[1:1];
$HELP←20;
! MOVE<fr>BY<vt> ≡ MOVE<fr>TO⊗+<vt>;
TOKEN←OLDOBJ;
#TOKEN←ID_TYPE;
STOKEN←TRUE;
$CLINR←"+"&$CLINR;
FDEST[1]←$$GTFREXP("destination of MOVE");
FRAM1←BELONGS (OLDOBJ,#FR);
MOVEPCODE(FRAM1,FDEST,1);
END;
PROCEDURE PTOPROC;
BEGIN
RPTR(FRAME) FRAM1; RPTR(EXPR$) ARRAY FDESTS[1:10]; INTEGER NFDEST;
NFDEST←0;
$HELP←20;
DO BEGIN
FDESTS[NFDEST←NFDEST+1]←$$GTFREXP("Destination part of MOVE");
IF NFDEST=10 THEN ERROR("Pointy cannot currently handle more than a 9 segment move");
GTOKEN(FALSE);
END UNTIL TOKEN≠",";
STOKEN←TRUE;
FRAM1←BELONGS (OLDOBJ,#FR);
MOVEPCODE(FRAM1,FDESTS,NFDEST);
END;
PROCEDURE MOVEPROC;
BEGIN
STRING FR1,AXIS;
$HELP←20;
FR1←IDF_READ;
GTOKEN;
OLDSAV("MOVE",FR1);
IF EQU(TOKEN,"TO") THEN PTOPROC
ELSE IF EQU(TOKEN,"BY") THEN PBYPROC
ELSE ERROR($SYNMSG[9],$SYNMSG[25]);
END;
PROCEDURE CENTERPROC;
BEGIN "PCENTER"
STRING POS;
$HELP←24;
POS←ARM_READ; ! if the arm is not indicated BARM is assumed;
IF EQU(POS,"BARM")
THEN $PCODE←$CENTERPCODE(BLUE)
ELSE PRINT(#NOTYET);
END "PCENTER";
! drives the indicated joint of the arm (what): movement is absolute
if how=to, differential if how=by;
PROCEDURE DRIVECODE(STRING WHAT,HOW;INTEGER JOINT;RPTR(EXPR$)SCAL);
$PCODE←$DRIVEPCODE((IF EQU(WHAT,"BJT") THEN BLUE
ELSE YELLOW),HOW,JOINT,SCAL);
! parses the instruction
DRIVE BJT|YJT (#) TO|BY <scalar>;
PROCEDURE JTMOVE(STRING WHAT,HOW;INTEGER JOINT);
BEGIN "J"
RPTR(EXPR$) SCAL;
$HELP←22;
SCAL←$$GTSCEXP("joint movement angle");
OLDSAV("DRIVE",CVS(JOINT)); ! saves for default instructions;
IF EQU(WHAT,"BJT") THEN
DRIVECODE(WHAT,HOW,JOINT,SCAL)
ELSE PRINT(#NOTYET);
END "J";
PROCEDURE DRIVEPROC;
BEGIN
STRING HOW;
STRING WHAT;INTEGER JOINT;
$HELP←22;
WHAT←IDF_READ;
IF EQU(WHAT,"BJT") OR EQU(WHAT,"YJT")
THEN BEGIN
WORD_READ("("); ! reads "(number)";
GTOKEN;
JOINT←INTSCAN(TOKEN,$BRCHR);
IF JOINT<1 OR JOINT>7
THEN ERROR("non existent joint: ",cvs(joint));
WORD_READ(")");
HOW←IDF_READ;
IF EQU(HOW,"BY") OR EQU(HOW,"TO")
THEN JTMOVE(WHAT,HOW,JOINT)
ELSE BEGIN
PRINT($SYNMSG[10],$SYNMSG[25]," OR ");
ERROR($SYNMSG[14],$SYNMSG[25]);
END;
END
ELSE ERROR("--→ BJT or YJT ",$SYNMSG[25]);
END;
PROCEDURE ALONGPROC(STRING AXIS,FRA1);
BEGIN
INTEGER I,INDEX;
RPTR(expr$)SCAL;RPTR(SYMBOL)SYMPTR;RPTR(FRAME)FRAM1;
INTEGER ARRAY BUFF1[1:3],BUFF3[1:5];
RPTR(EXPR$)ARRAY PTR[1:3],DEST[1:1];
$HELP←21;
SCAL←$$GTSCEXP("distance to be moved along axis");
SYMPTR←CHECK(AXIS[1 TO 1]&"HAT",#VT);
OLDSAV("MOVE"&AXIS[1 TO 1],FRA1); ! saves for default instructions;
FRAM1←BELONGS(FRA1,#FR);
INDEX←0;
FOR I←XAGTVAL, SYMBOL:INDEX[SYMPTR],SYMBOL:OFFSET[SYMPTR],
XSVMUL, XTVADD DO BUFF3[INDEX←INDEX+1]←I;
SYMPTR←CHECK(FRA1,#FR);
INDEX←0;
IF SYMBOL:INDEX[SYMPTR]>0 THEN
FOR I←XAGTVAL, SYMBOL:INDEX[SYMPTR],SYMBOL:OFFSET[SYMPTR]
DO BUFF1[INDEX←INDEX+1]←I
ELSE FOR I←XGTVAL, SYMBOL:OFFSET[SYMPTR],XNOOP
DO BUFF1[INDEX←INDEX+1]←I;
PTR[1]←αEXPR$(BUFF1,0);
PTR[2]←SCAL;
PTR[3]←αEXPR$(BUFF3,0);
DEST[1]←$AAPPEND(PTR);
MOVEPCODE(FRAM1,DEST,1);
END;
! moves the frame along one axis by a scalar;
PROCEDURE AXMOVPROC;
BEGIN
STRING FRA1,AXIS;
$HELP←21;
AXIS←TOKEN[5 TO 5];
FRA1←MVFR_READ;
WORD_READ("BY");
ALONGPROC(AXIS,FRA1);
END;
! executes close or open instruction. How determines if the movement is
absolute (to) or differential (by), op indicates the operation(open/close);
PROCEDURE OPCLCODE(STRING OP,HAND,HOW;RPTR(EXPR$)SCAL);
BEGIN
IF EQU(HAND,"BHAND")
THEN IF EQU(HOW,"TO") OR EQU(OP,"OPEN")
THEN DRIVECODE("BJT",HOW,7,SCAL)
ELSE DRIVECODE("BJT",HOW,7,$APPEND(SCAL,EXPR$1(XSNEG),#SC))
ELSE PRINT(#NOTYET);
END;
PROCEDURE PARKINGPROC;
BEGIN
STRING PAR; $HELP←25 ;
GTOKEN(FALSE);
IF FINAL THEN ASKUSER("MOVE BARM TO BPARK; {MOVE YARM TO YPARK}")
ELSE IF EQU(TOKEN,"BARM") THEN ASKUSER("MOVE BARM TO BPARK")
ELSE IF EQU(TOKEN,"YARM") THEN ASKUSER("MOVE YARM TO YPARK")
ELSE ERROR("can only park BARM or YARM");
$PCODE←PARSE;
END;
! system facilities: editcode,renmcode;
IFC NOT #NOFUNCT THENC
PROCEDURE UNRAVEL_SYMBOLS_USED(RPTR(expr)SYMBOLSUSED;RPTR(SYMBOL)EL);
BEGIN RPTR(SYMBOL)EL2;
RPTR(expr)SY,SY2; INTEGER NARGS; NARGS←0;
SY←SYMBOLSUSED;
WHILE SY≠NULL_RECORD DO BEGIN NARGS←NARGS+1; SY←EXPR:NEXT[SY]; END;
IF NARGS>0 THEN
BEGIN RPTR(EXPR)ARRAY SS[1:NARGS]; INTEGER I;
SY←SYMBOLSUSED;
FOR I←1 STEP 1 UNTIL NARGS DO
BEGIN
INTEGER J,JJ;
SS[I]←SY;
EL2←EXPR:PTR[SY];
ADDSYMUSED(EL,EL2);
SY←EXPR:NEXT[SY2←SY];
EXPR:NEXT[SY2]←NULL_RECORD;
END;
MEMORY[LOCATION(SYMBOL:USES[EL])]←MEMORY[LOCATION(SS)];
MEMORY[LOCATION(ss)]←0;
SYMBOL:NUSES[EL]←NARGS;
END;
END;
ENDC
! edits values of the variable var;
PROCEDURE EDITCODE (STRING VAR);
BEGIN
RPTR(SYMBOL)EL;INTEGER OBTYPE;STRING FBODY;
RPTR(SCALAR,VECTOR,TRANS,FRAME,ROT,MACRO) TEMP;
NOEXPAND ← TRUE;
EL←OLDSYM(VAR,OBTYPE); ! var must exist in $YMTAB;
TEMP←SYMBOL:OBJECT[EL];
IF OBTYPE = #MC
THEN BEGIN
INTEGER BRCHAR;
STRING OLD_STRING,NEW_STRING,LINE_STRING;
OLD_STRING← "DEFINE "&MACRO:HEAD[SYMBOL:OBJECT[EL]]
&" = "&CVSYM(EL,EDIT_D)&";";
NEW_STRING←LINE_STRING←NULL;
WHILE OLD_STRING DO
BEGIN LINE_STRING←SCAN(OLD_STRING,$CRTAB,BRCHAR);
LODED(LINE_STRING&CR);
NEW_STRING←NEW_STRING&INCHWL&CRLF;
END;
ASKUSER(NEW_STRING);
DELSYM(EL);
END
ELSE BEGIN
SETFORMAT(0,7);
IF PRDECL(EL) THEN ABORT1(VAR,$SEMSG[14]);
IF OBTYPE=#FR AND FRAME:HOWLINKED[TEMP]≠#INDLK
THEN PRINT("values of ",VAR," are relative to ",
FRAME:PNAME[FRAME:DAD[TEMP]],CRLF);
! ELSE IF OBTYPE=#FN THEN VAR←FUNCTION:HEAD[TEMP];
PRINT("value of ",VAR," = ");
IF OBTYPE=#PR THEN ERROR("Cant edit procedures yet");
LODED(CVX(TEMP,OBTYPE,EDIT_D)&CR);
ASKUSER;
IFC NOT #NOFUNCT THENC
IF OBTYPE=#FN THEN α RPTR(EXPR)SYMBOLSUSED;
TEMP1←FNEXPR(TEMP,FBODY,SYMBOLSUSED);
BEGIN RPTR(EXPR) T;
T←NEW_RECORD(EXPR);
EXPR:PTR[T]←TREE:DATA[TEMP1];
EXPR:TYPE[T]←TREE:DTYPE[TEMP1];
FUNCTION:EXPR[TEMP]←T;
END;
DELSYMREF(EL);
UNRAVEL_SYMBOLS_USED(SYMBOLSUSED,EL);
FUNCTION:BODY[TEMP]←FBODY; β
ELSE ENDC ASGEX2(VAR);
SETFORMAT(0,3);
END;
NOEXPAND ← FALSE;
END;
! allows renaming a variable;
PROCEDURE RENMCODE(STRING VAR);
BEGIN
RPTR(SYMBOL)OLDEL;INTEGER OBTYPE;STRING NEW;
STRING SFSF;
NOEXPAND ← TRUE;
SFSF ← VAR;
OLDEL←OLDSYM(VAR,OBTYPE); ! var must exist in $YMTAB;
PRINT("new name = ");
NEW←RECOVER(VAR); ! reads the new name;
IF NEW NEQ SFSF
THEN NEW←NEWSYM(NEW); ! checks new doesn't exist;
IFC #OUTPT THENC IF $OUT THEN CPRINT($TTYCH,NEW,CRLF);ENDC
SYMBOL:PNAME[OLDEL]←NEW; ! changes the name in record symbol;
IF OBTYPE=#FR
THEN FRAME:PNAME[SYMBOL:OBJECT[OLDEL]]←NEW;
$DISPLAYLIST[OBTYPE]←NULL;
NOEXPAND ← FALSE;
END;
! parse procedures: affixproc,defineproc,unfixproc;
PROCEDURE UNFIXPROC;
BEGIN
RPTR(EXPR$)EX1,EX2; RPTR(SYMBOL)FRM1,FRM2;
$HELP←15;
EX1←$$GTIDREF(#FR,FRM1,"first frame of unfix");
WORD_READ("FROM"); ! change this to handle just UNFIX FRAME1;
EX2←$$GTIDREF(#FR,FRM2,"second frame of UNFIX");
$PCODE←$UFXPCODE(EX1,EX2);
END;
! parses the instruction
AFFIX <frame_id> TO <frame_id> {AT TRANS(<rot>,<vector>)};
PROCEDURE AFFIXPROC;
BEGIN
INTEGER AFFTYPE;RPTR(EXPR$)TEMP;
RPTR(EXPR$)EX1,EX2; RPTR(SYMBOL)FRM1,FRM2;
$HELP←16;
EX1←$$GTIDREF(#FR,FRM1,"first frame of affix");
WORD_READ("TO");
EX2←$$GTIDREF(#FR,FRM2,"second frame of affix");
GTOKEN(FALSE);
TEMP←NULL_RECORD;
IF EQU(TOKEN,"AT")
THEN BEGIN "AT"
TEMP←$$GTFREXP("offset part of AFFIX statement");
GTOKEN(FALSE);
END "AT";
IF FINAL
THEN AFFIXCODE(EX1,EX2,#RGDLK,TEMP)
ELSE BEGIN "D"
IF TOKEN="+" OR EQU(TOKEN,"NONRIGIDLY")
THEN AFFTYPE← #NRGLK
ELSE IF TOKEN="*" OR EQU(TOKEN,"RIGIDLY")
THEN AFFTYPE← #RGDLK
ELSE ERROR($SYNMSG[30],NULL);
SEMICOL_READ;
AFFIXCODE(EX1,EX2,AFFTYPE,TEMP);
END "D";
END ;
PROCEDURE DEFINEPROC;
BEGIN RPTR(MACRO) MACPTR; STRING MACNAME; INTEGER DDLCOUNT; STRING BODY,NBODY;
INTEGER NPARAM;
NPARAM←0;
NOEXPAND ← TRUE;
GTOKEN;
IF #TOKEN ≠ UNDECLARED_TYPE
THEN ERROR("MACRO DEFINITION: need undeclared identifier");
DDLCOUNT ← 0;
MACPTR ← NEW!RECORD(MACRO);
MACNAME ← TOKEN;
GTOKEN;
IF TOKEN≠"("
THEN BEGIN STOKEN←TRUE; MACRO:HEAD[MACPTR]←MACNAME; END
ELSE
BEGIN "parametered macro"
RPTR(PLIST) TEMP,TEMP0;
TEMP0←NULL_RECORD;
DO
BEGIN "get parameters"
GTOKEN;
IF #TOKEN ≠ UNDECLARED_TYPE THEN
ERROR("MACRO DEFINITION: need undeclared token for argument");
NPARAM←NPARAM+1;
TEMP←NEW!RECORD(PLIST);
PLIST:NEXTP[TEMP]←TEMP0;
PLIST:PARAM[TEMP]←TOKEN;
TEMP0←TEMP;
GTOKEN;
IF TOKEN≠")" AND TOKEN≠","
THEN ERROR("MACRO DEFINITION: Need comma here");
END "get parameters" UNTIL TOKEN=")";
BEGIN
INTEGER I; STRING ARRAY S[1:NPARAM];
STRING HEAD; HEAD←")";
FOR I←NPARAM STEP -1 UNTIL 1 DO
BEGIN
HEAD←","&(S[I]←PLIST:PARAM[TEMP])&HEAD;
TEMP←PLIST:NEXTP[TEMP];
END;
MEMORY[LOCATION(S)]↔MEMORY[LOCATION(MACRO:PRLIST[MACPTR])];
MACRO:HEAD[MACPTR]←MACNAME&"("&HEAD[2 TO ∞];
END;
MACRO:NPARAM[MACPTR]←NPARAM;
END "parametered macro";
WORD_READ("=");
WORD_READ("⊂"); DDLCOUNT ← 1;
BODY←"⊂";
DO BEGIN
INTEGER I;
I←READTILL("⊂⊃");
BODY←BODY&TOKEN&I;
IF I="⊂"
THEN DDLCOUNT ← DDLCOUNT + 1
ELSE DDLCOUNT ← DDLCOUNT - 1;
END UNTIL DDLCOUNT=0;
BODY←BODY[2 TO ∞-1];
IF NPARAM>0 THEN
BEGIN
NBODY←NULL;
WHILE BODY DO
BEGIN "process the parameters"
INTEGER I;
INTEGER BRCHAR; STRING TTOKEN;
NBODY←NBODY&SCAN(BODY,$LTTAB,BRCHAR);
TTOKEN←SCAN(BODY,$NLTTAB,BRCHAR);
FOR I←1 STEP 1 UNTIL NPARAM
DO IF EQU(MACRO:PRLIST[MACPTR][I],TTOKEN) THEN DONE;
IF I>NPARAM THEN
NBODY←NBODY&TTOKEN
ELSE NBODY←NBODY&DUMMY_DELIM&TTOKEN&DUMMY_DELIM;
END "process the parameters";
END ELSE NBODY←BODY;
MACRO:BODY[MACPTR]←NBODY;
SEMICOL_READ;
ENSYM(MACNAME, #MC, MACPTR);
NOEXPAND ← FALSE;
$MCLST←NULL;
END;
! parse procedures: opclproc,copyproc;
PROCEDURE OPENING(STRING FIRST,WHAT,HOW);
BEGIN
RPTR(EXPR$)SCAL;
$HELP←23;
SCAL←$$GTSCEXP("hand opening or closing");
OLDSAV(FIRST,WHAT); ! saves for default instructions;
OPCLCODE(FIRST,WHAT,HOW,SCAL);
END;
! parses the instructions
OPEN <hand> TO|BY <scalar>;
! CLOSE <hand> TO|BY <scalar>;
PROCEDURE OPCLPROC(STRING FIRST);
BEGIN
STRING WHAT;
$HELP←23;
WHAT←HAND_READ;
GTOKEN;
IF EQU(TOKEN,"TO") OR EQU(TOKEN,"BY")
THEN OPENING(FIRST,WHAT,TOKEN)
ELSE ERROR("Need a TO or BY for OPEN/CLOSE statement");
END;
! closes any open file, after a confirmation;
PROCEDURE FCLPROC;
BEGIN
STRING ANSWER;
$HELP←36;
SEMICOL_READ;
PRINT("Any open file will be closed. Are you sure?");
ANSWER←INCHRW;
PRINT(CRLF);
ESC_P;
IF ANSWER="Y" OR ANSWER="y"
THEN BEGIN
IFC #OUTPT THENC FCLOSE;ENDC
END
ELSE ABORT1($SEMSG[13]);
IFC #OUTPT THENC TTYSAVE; ENDC ! file status modified;
$OULST←NULL;
END;
! parses the instructions
CLOSE {<filename>} (default=last used file)
CLOSE <hand> TO|BY <scalar> (BHAND as default);
PROCEDURE CLOSEPROC;
BEGIN
STRING FL,ANSWER;
$HELP←30;
GTOKEN(FALSE);
IF FINAL THEN
IFC #OUTPT THENC AL_CLOSE($ALFL) ELSEC ABORT1(#VERSION) ENDC
ELSE
BEGIN "MORE"
IF EQU(TOKEN,"BHAND") OR EQU(TOKEN,"YHAND")
OR EQU(TOKEN,"TO") OR EQU(TOKEN,"BY")
THEN BEGIN "HAND"
STRING WHAT; INTEGER IND;
WHAT←TOKEN;
GTOKEN(FALSE);
IF FINAL
THEN
IFC #OUTPT THENC
BEGIN "FILECHECK"
IND←ISFILE(WHAT);
IF IND THEN
BEGIN
PRINT("do you want to close the file?");
ANSWER←INCHRW;
PRINT(CRLF);ESC_P;
IF ANSWER="Y" OR ANSWER="y"
THEN AL_CLOSE(WHAT)
ELSE ABORT1($SEMSG[13]);
END
ELSE
IF EQU(WHAT,"BHAND") OR EQU(WHAT,"YHAND") THEN
BEGIN
STRING HOW;
HOW←IDF_READ;
IF EQU(HOW,"BY") OR EQU(HOW,"TO")
THEN OPENING("CLOSE",WHAT,HOW)
ELSE BEGIN
PRINT($SYNMSG[10],$SYNMSG[25]," OR ");
ERROR($SYNMSG[14],$SYNMSG[25]);
END;
END
ELSE OPENING("CLOSE","BHAND",WHAT);
END "FILECHECK"
ELSEC PRINT(#VERSION) ENDC
ELSE
IF EQU(WHAT,"TO") OR EQU(WHAT,"BY") THEN
BEGIN
STOKEN←TRUE;
OPENING("CLOSE","BHAND",WHAT); ! default=BHAND;
END
ELSE
IF EQU(TOKEN,"TO") OR EQU(TOKEN,"BY") THEN
OPENING("CLOSE",WHAT,TOKEN)
ELSE BEGIN
PRINT($SYNMSG[10],$SYNMSG[25]," OR ");
ERROR($SYNMSG[14],$SYNMSG[25]);
END;
END "HAND"
ELSE
BEGIN
STOKEN←TRUE;
FL←NAMEFILE;
SEMICOL_READ;
IFC #OUTPT THENC AL_CLOSE(FL);ENDC
END;
END "MORE";
END;
! parses the instructions
MERGE <frame_id> INTO <frame_id>
COPY <frame_id> INTO <frame_id>
First is MERGE or COPY;
! MERGE <frame_id> is now COPY SUBTREE(<frame_id>) ;
PROCEDURE COPYPROC;
BEGIN
STRING FR1,FR2,FIRST;
$HELP←14;
GTOKEN;
IF EQU(TOKEN,"SUBTREE") THEN
BEGIN
WORD_READ("("); FR1←IDF_READ;
WORD_READ(")"); FIRST←"MERGE";
END
ELSE
BEGIN
STOKEN←TRUE;
FR1←IDF_READ; ! reads first frame;
FIRST←"COPY";
END;
WORD_READ("INTO"); ! reads INTO;
FR2←IDF_READ; ! reads second frame;
SEMICOL_READ;
COPYCODE(FIRST,FR1,FR2);
END;
! parse procedures: declproc,simpledeclproc,arraydeclproc,procdeclproc,returnproc;
PROCEDURE PROCDECLPROC(INTEGER OBTYPE(#PR));
BEGIN "procedure declaration"
STRING ATOKEN;INTEGER NARGS,SYMACCS;
INTEGER ARRAY ACCESS,TYPE,ARRDIM,ARGOFF[1:10];
STRING ARRAY ARGNAME[1:10];
RPTR(SYMBOL) ARRAY SYMARR[1:10];
RPTR(PROC)PSYM; RPTR(EXPR$)PBODY; RPTR(SYMBOL)SYM; RANY DATPTR;
IF CURPROC THEN ERROR("Cant have procedure inside procedure");
IF CURBLOCK THEN ERROR("Cant have procedure inside block");
$COMPILE←$COMPILE+1; $LEVEL←1;
GTOKEN;
IF #TOKEN≠UNDECLARED_TYPE THEN
ERROR("Need undeclared identifier for procedure declaration");
ATOKEN←TOKEN;
NARGS←0; $TMPOFF←'1000-1; ! starting value ;
GTOKEN;
IF TOKEN="(" THEN
DO BEGIN "procedure with parameters"
INTEGER CACCESS,CTYPE; BOOLEAN ARRDECL;
GTOKEN;
ARRDECL←FALSE;
CACCESS←#REFTYP; SYMACCS←#SIMPLE;
IF EQU(TOKEN,"VALUE") THEN CACCESS←0
ELSE IF EQU(TOKEN,"REFERENCE") THEN CACCESS←#REFTYP
ELSE STOKEN←TRUE;
GTOKEN;
FOR CTYPE←#SC STEP 1 UNTIL #FR DO
IF EQU(TOKEN,$DTYPE[CTYPE]) THEN DONE;
IF NOT(#SC≤CTYPE≤#FR) THEN ERROR("Need basic data type declaration here");
GTOKEN;
DATPTR←NULL_RECORD;
IF EQU(TOKEN,"ARRAY") THEN
BEGIN CACCESS←#REFTYP+#ARRTYP;
ARRDECL←TRUE; SYMACCS←#ARRAY;
END ELSE STOKEN←TRUE;
DO BEGIN "get list of parameters"
INTEGER I;
IF NARGS>10 THEN ERROR("Cant take more than 10 parameters");
GTOKEN;
! now check if we have used this before ;
IF NOT(#TOKEN≠UNDECLARED_TYPE OR #TOKEN≠ID_TYPE) THEN
ERROR("Need undeclared or id token here");
FOR I←1 STEP 1 UNTIL NARGS DO
IF EQU(TOKEN,ARGNAME[I]) THEN DONE;
IF EQU(TOKEN,ATOKEN) THEN I←NARGS;
IF I≠NARGS+1 THEN ERROR(TOKEN&" has already been used in this procedure");
NARGS←NARGS+1;
TYPE[NARGS]←CTYPE; ACCESS[NARGS]←CACCESS;
ARGNAME[NARGS]←TOKEN;
ARGOFF[NARGS]←($TMPOFF←$TMPOFF+1);
IF ARRDECL THEN
BEGIN "array in argument list"
RPTR(EXPR$)E;
INTEGER I; I←0;
WORD_READ("[");
DO BEGIN "no of arguments"
E←$$GTSCEXP("for field of array declaration");
WORD_READ(":");
E←$$GTSCEXP("for dimension field of array dec");
I←I+1;
GTOKEN;
IF TOKEN≠"," AND TOKEN≠"]" THEN ERROR("Need , or ] here");
END "no of arguments" UNTIL TOKEN="]";
IF I>5 THEN ERROR("Array dimension must be less than 5");
ARRAYREC:#DIM[DATPTR←NEW_RECORD(ARRAYREC)]←ARRDIM[NARGS]←I;
END "array in argument list";
SYMBOL:OFFSET[SYMARR[NARGS]←MK_SYM(ARGNAME[NARGS],
TYPE[NARGS],DATPTR,SYMACCS)] ← $TMPOFF;
GTOKEN;
END "get list of parameters" UNTIL TOKEN≠",";
IF TOKEN≠")" AND TOKEN≠";" THEN ERROR("Need ; or , or ) here");
END "procedure with parameters" UNTIL TOKEN=")"
ELSE STOKEN←TRUE;
WORD_READ(";");
PSYM←MK_PR(NARGS,ARGNAME,TYPE,ACCESS,ARRDIM);
SYM←CURPROC←MK_SYM(ATOKEN,OBTYPE,PSYM,#PROCEDURE);
SYMBOL:OFFSET[CURPROC]←$SYMOFF;
CURBLOCK←BLOCKIFY(NARGS,SYMARR);
BLOCKREC:LEVEL[CURBLOCK]←$LEVEL;
PBODY←PARSE;
$PCODE←$PRCDCLPCODE(SYM,PBODY);
ENSYM$(SYM);
$SYMOFF←$SYMOFF+1;
$COMPILE←$COMPILE-1;
END;
IFC NOT #nofunct THENC
PROCEDURE FUNCTPROC(INTEGER OBTYPE(0);STRING OBSTRING(NULL));
BEGIN
STRING SSSS;
PROCEDURE GGTOKEN;
BEGIN GTOKEN; SSSS←SSSS&" "&TOKEN; END;
SSSS←OBSTRING&" "&TOKEN;
$HELP←0;
BEGIN "declar function"
INTEGER NARGS; RPTR(SYMBOL) S;integer tt,FT; STRING FBODY;
RPTR(EXPR) SYMBOLSUSED;
RCLASS TEMP(RPTR(EXPR) PTR; INTEGER TYPE;
STRING NAME;RPTR(TEMP)NEXT);
RPTR (TEMP) T,T1;RPTR(TREE)TRE;RPTR(FUNCTION) F; STRING FNAME;
NARGS←0; GGTOKEN;
IF #TOKEN≠UNDECLARED_TYPE
THEN ERROR($SYNMSG[35],$SYNMSG[25])
ELSE BEGIN "declar function"
FNAME←TOKEN;
GGTOKEN; T←NEW_RECORD(TEMP);
IF TOKEN="(" THEN
BEGIN "parametic procedure "
DO BEGIN "declar param type"
GGTOKEN;
IF EQU(TOKEN,"SCALAR") THEN FT←#SC
ELSE IF EQU(TOKEN,"VECTOR") THEN FT←#VT
ELSE IF EQU(TOKEN,"ROT") THEN FT←#RT
ELSE IF EQU(TOKEN,"TRANS") THEN FT←#TR
ELSE IF EQU(TOKEN,"FRAME") THEN FT←#FR
ELSE ERROR("need declaration class");
DO BEGIN "declar param"
GGTOKEN;
IF #TOKEN≠UNDECLARED_TYPE
THEN ERROR("function parameter should be undeclared variable");
T1←NEW_RECORD(TEMP);
TEMP:TYPE[T1]←FT;TEMP:NAME[T1]←TOKEN;
TEMP:NEXT[T1]←T;T←T1;NARGS←NARGS+1;GGTOKEN;
END "declar param"
UNTIL TOKEN≠",";
END "declar param type"
UNTIL TOKEN≠";" ;
IF TOKEN ≠ ")" THEN ERROR("need close paren or semicolon here");
END "parametic procedure "
ELSE BEGIN STOKEN←TRUE; SSSS←SSSS[1 TO ∞ - 1]; END;
F←MK_FN(NARGS); FUNCTION:TYPE[F]←OBTYPE; FUNCTION:HEAD[F]←SSSS;
FOR TT←NARGS STEP -1 UNTIL 0 DO
BEGIN
EXPR:TYPE[FUNCTION:PTR[F][TT]←NEW_RECORD(EXPR)]←
FUNCTION:ARGTYPE[F][TT]←TEMP:TYPE[T];
FUNCTION:ARGNAME[F][TT]←TEMP:NAME[T];
T←TEMP:NEXT[T];
END;
GGTOKEN;
IF TOKEN≠"=" THEN ERROR("need = here");
TRE←FNEXPR(F,FBODY,SYMBOLSUSED);
BEGIN RPTR(EXPR) T;
T←NEW_RECORD(EXPR);
EXPR:PTR[T]←TREE:DATA[TRE];
ifc false thenc buggy right now IF OBTYPE=0 THEN
BEGIN EXPR:TYPE[T]←TREE:DTYPE[TRE];
obtype←expr:type[expr:ptr[t]];
function:type[f]←obtype mod #dtype;
function:head[f]←$dtype[obtype mod #dtype]&function:head[f];
END
ELSE
IF (EXPR:TYPE[T]←TREE:DTYPE[TRE])mod #dtype≠OBTYPE
THEN ERROR("function type not same as declared");
elsec expr:type[t]←tree:dtype[tre];endc FUNCTION:EXPR[F]←T;
END;
FUNCTION:BODY[F]←FBODY;
S←INSERT(FNAME,#FN); SYMBOL:OBJECT[S]←F;
UNRAVEL_SYMBOLS_USED(SYMBOLSUSED,S);
IFC #DISPL THENC $FNLST←NULL; UPDATE; ENDC
END "declar function";
END "declar function";
END;
ENDC
forward procedure notavailproc;
! parses the declaration instructions
SCALAR <id>,<id>,...
VECTOR <id>,<id>,...
FRAME <id>,<id>,...
ROT <id>,<id>,...;
PROCEDURE SIMPLEDECL(INTEGER OBTYPE);
BEGIN
RPTR(SYMBOL)ARRAY SPTR[1:10];
INTEGER I,J; J←0;
DO BEGIN "A"
IF J=10 THEN ERROR("Can only declare 10 variables in a declaration");
GTOKEN;
IF (CURBLOCK=NULL_RECORD AND #TOKEN≠UNDECLARED_TYPE)
OR (CURBLOCK≠NULL_RECORD AND $LEVEL=TOKENLEVEL)
THEN ERROR($SYNMSG[35],$SYNMSG[25])
ELSE BEGIN "check current list"
INTEGER K;
FOR K←1 STEP 1 UNTIL J DO
IF EQU(SYMBOL:PNAME[SPTR[K]],TOKEN) THEN DONE;
IF K=J+1 THEN SPTR[J←J+1]←NNWR(TOKEN,OBTYPE)
ELSE ERROR(TOKEN&" is not undeclared");
END "check current list";
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL
THEN ERROR($SYNMSG[0]&$SYNMSG[25]&" OR ",$SYNMSG[1]&$SYNMSG[25]);
END "A" UNTIL FINAL;
IF CURBLOCK
THEN FOR I←1 STEP 1 UNTIL J DO
BEGIN INSERTSYMTREE(SPTR[I],CURBLOCK);
SYMBOL:OFFSET[SPTR[I]]←($TMPOFF←$TMPOFF+1);
$PCODE←$SMPDCLPCODE(OBTYPE,J);
STOKEN←TRUE;
END
ELSE FOR I←1 STEP 1 UNTIL J DO ENSYM$(SPTR[I]);
$DISPLAYLIST[OBTYPE]←NULL;
END;
! to handle array declarations;
PROCEDURE ARRAYDECLPROC(INTEGER OBTYPE);
BEGIN "array declaration"
RPTR(EXPR$)PARRAY;
INTEGER NARRAY;
RPTR(EXPR$) ARRAY PLIST[1:10];
RPTR(SYMBOL) ARRAY SYMLST[1:10];
NARRAY←0;
DO BEGIN "get another one"
STRING ATOKEN; INTEGER ADIM; RPTR(EXPR$)ARRAY BOUNDS[1:10];
RPTR(ARRAYREC) DIMREC;
IF NARRAY≥10 THEN ERROR("Can't have more than 10 variables in a declaration");
ADIM←0; GTOKEN;
IF (CURBLOCK=NULL_RECORD AND #TOKEN≠UNDECLARED_TYPE)
OR (CURBLOCK≠NULL_RECORD AND $LEVEL=TOKENLEVEL)
THEN ERROR("Need undeclared identifier for array declaration");
ATOKEN←TOKEN; WORD_READ("[");
DO BEGIN
IF ADIM=5 THEN ERROR("Cant have more than 5 fields in array declaration");
BOUNDS[ADIM*2+1]←$$GTSCEXP("for array dimension");
WORD_READ(":"); BOUNDS[ADIM*2+2]←$$GTSCEXP("for array dimension");
GTOKEN;
IF TOKEN≠"," AND TOKEN≠"]"THEN ERROR("Need , here"); ADIM←ADIM+1;
END UNTIL TOKEN="]";
PLIST[NARRAY←NARRAY+1]←$ARRDCLPCODE(ATOKEN,BOUNDS,OBTYPE,ADIM);
ARRAYREC:#DIM[DIMREC←NEW_RECORD(ARRAYREC)]←ADIM;
SYMLST[NARRAY]←MK_SYM(ATOKEN,OBTYPE,DIMREC,#ARRAY);
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL THEN ERROR("Need a comma or semicolon here");
END UNTIL FINAL;
IF TOKEN=";" THEN STOKEN←TRUE;
PARRAY←NULL_RECORD;
IF CURBLOCK THEN
BEGIN INTEGER I; RPTR(SYMBOL)S;
FOR I←1 STEP 1 UNTIL NARRAY DO
BEGIN
INSERTSYMTREE(S←SYMLST[I],CURBLOCK);
SYMBOL:OFFSET[S]←($TMPOFF←$TMPOFF+1);
PARRAY←$APPEND(PARRAY,PLIST[I]);
END;
END
ELSE BEGIN
INTEGER I; RPTR(SYMBOL)TEMP;
FOR I← 1 STEP 1 UNTIL NARRAY DO
BEGIN
ENSYM$(TEMP←SYMLST[I]);
SYMBOL:OFFSET[TEMP]←$SYMOFF;$SYMOFF←$SYMOFF+1;
PARRAY←$APPEND(PARRAY,PLIST[I]);
END;
END;
$PCODE←PARRAY;
END "array declaration";
PROCEDURE DECLPROC (INTEGER OBTYPE);
BEGIN
$HELP←0;
GTOKEN;
IF EQU(TOKEN,"PROCEDURE")
THEN PROCDECLPROC(OBTYPE)
ELSE IF EQU(TOKEN,"ARRAY")
THEN ARRAYDECLPROC(OBTYPE)
ELSE BEGIN
STOKEN←TRUE;
SIMPLEDECL(OBTYPE);
END;
END;
PROCEDURE RETURNPROC;
BEGIN RPTR(EXPR$)EXP;
IF $COMPILE=0 THEN ERROR("RETURN can only be inside a block");
EXP←NULL_RECORD; GTOKEN;
IF TOKEN="(" THEN
BEGIN EXP←$$GTEXPR; GTOKEN;
IF TOKEN≠")" THEN ERROR("Need right paren here");
END
ELSE STOKEN←TRUE;
$PCODE←$RTNPCODE(EXP);
END;
! parse procedures: deleteproc,editproc,printproc,exitproc;
! used after reading DISTANCE to read VECTOR in declaration statement;
! parses the instructions
DELETE <variable>,<variable>,..
DELETE (deletes all the variables defined by the user);
PROCEDURE DELETEPROC(BOOLEAN QUIET(FALSE));
BEGIN
STRING VAR;
IF $COMPILE≠0 THEN ERROR("DELETE: cannot be invoked inside a block or procedure");
NOEXPAND ← TRUE;
$HELP←1;
GTOKEN(FALSE);
IF FINAL OR EQU(TOKEN,"ALL")
THEN IF QUIET OR EQU(TOKEN,"ALL") THEN RESET
ELSE BEGIN ! deletes all the variables;
STRING ANSWER;
PRINT("are you sure all variables are to be deleted? ");
ANSWER←INCHRW;
PRINT(CRLF);ESC_P;
IF ANSWER="Y" OR ANSWER="y"
THEN RESET
ELSE ABORT1($SEMSG[13]);
END
ELSE BEGIN
STOKEN←TRUE;
$ALLOW←$ALLOW+1;
DO BEGIN "A"
VAR←IDF_READ;
KILLVAR(TOKEN,QUIET);
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL
THEN BEGIN
PRINT($SYNMSG[0],$SYNMSG[25]," OR ");
ERROR($SYNMSG[1],$SYNMSG[25] );
END;
END "A"
UNTIL FINAL;
$ALLOW←$ALLOW-1;
END;
NOEXPAND ← FALSE;
END;
! common code for PRINT, PROMPT, and ABORT;
PROCEDURE PRINTPROC(RPTR(EXPR$)EE(NULL_RECORD));
BEGIN
RPTR(EXPR$)P; P←NULL_RECORD;
WORD_READ("(");
DO BEGIN
GTOKEN;
IF TOKEN=dquote
THEN BEGIN "string found"
READTILL(dquote);
P←$APPEND(P,$PRNPCODE(TOKEN))
END
ELSE BEGIN "expression found"
STOKEN←TRUE;
P←$APPEND(P,$PRVPCODE($$GTEXPR));
END;
GTOKEN;
END UNTIL TOKEN≠",";
IF TOKEN≠")" THEN ERROR("Need ) for end of PRINT list");
$PCODE←$APPEND(P,EE);
END;
PROCEDURE EDITPROC(STRING WHAT);
BEGIN
STRING VAR;
NOEXPAND←TRUE;
IF EQU(WHAT,"EDIT")THEN $HELP←37 ELSE $HELP←38;
VAR←IDF_READ;
SEMICOL_READ;
IF EQU(WHAT,"EDIT") THEN EDITCODE(VAR)ELSE RENMCODE(VAR);
END;
PROCEDURE EXITPROC;
BEGIN
$HELP←9;
SEMICOL_READ;
GOTO DONEPOINTY;
END;
! parse procedures: other, readwristproc,setbaseproc,wristproc;
PROCEDURE DEFLT(STRING HOW);
BEGIN
IF EQU(OLDCMD,"OPEN") OR EQU(OLDCMD,"CLOSE")
THEN OPENING(OLDCMD,OLDOBJ,HOW)
ELSE IF EQU(OLDCMD,"MOVEX")OR EQU(OLDCMD,"MOVEY")OR EQU(OLDCMD,"MOVEZ")
THEN IF HOW="BY"
THEN ALONGPROC(OLDCMD[5 FOR 1],OLDOBJ)
ELSE ERROR($SYNMSG[10],$SYNMSG[25])
ELSE IF EQU(OLDCMD,"DRIVE")
THEN JTMOVE("BJT",HOW,CVD(OLDOBJ))
ELSE IF EQU(OLDCMD,"MOVE")
THEN IF EQU(HOW,"BY") THEN PBYPROC ELSE PTOPROC;
END;
PROCEDURE ASGMNT(STRING FIRST;RPTR(SYMBOL)S);
IF (S≠NULL_RECORD) AND PRDECL(S) THEN
ERROR("You cannot change the value of "&FIRST)
ELSE ASGEX2(FIRST,NULL_RECORD,S);
PROCEDURE OTHER;
BEGIN STRING FIRST; RPTR(SYMBOL)SS; RPTR(EXPR$)EE;
$HELP←41; FIRST←TOKEN; EE←NULL_RECORD;
IF (SS←TOKENPTR)≠NULL_RECORD THEN
BEGIN IF SYMBOL:ACCESS[TOKENPTR]=#ARRAY
THEN EE←AREF(TOKENPTR,XCHNGE)
ELSE IF SYMBOL:ACCESS[TOKENPTR]=#PROCEDURE
THEN BEGIN $PCODE←PREF(TOKENPTR);
RETURN; END;
END;
GTOKEN;
IF TOKEN="←"
THEN IF EE THEN ASGEX3(EE) ELSE ASGMNT(FIRST,SS)
ELSE ERROR($SYNMSG[32],NULL);
END;
IFC #WRIST THENC
PROCEDURE READWRISTPROC;
BEGIN STRING COMMAND,FNAME; INTEGER VAL;
IF $COMPILE≠0 THEN PRINT(CRLF,"WARNING: you should not put READWRIST
inside a block...",crlf,"We make no promises",CRLF);
VAL←0;FNAME←NULL;
WORD_READ("(");
GTOKEN;
COMMAND←TOKEN;
IF EQU("CALIB",COMMAND) OR EQU("RENAMEFILE",COMMAND) THEN
BEGIN
GTOKEN;
IF TOKEN≠"," THEN ERROR("Need comma after CALIB or RENAMEFILE");
IF EQU(COMMAND,"CALIB") THEN
BEGIN
GTOKEN;
VAL←INTSCAN(TOKEN,$BRCHR);
IF VAL<1 OR VAL>6
THEN ERROR("Calib code must be between 1 and 6");
END
ELSE FNAME←NAMEFILE;
END
ELSE IF EQU("SAVERAWDATA",COMMAND) THEN
BEGIN
STRING S; S←NULL;
GTOKEN;
IF TOKEN≠"," THEN ERROR("Need comma after SAVERAWDATA");
GTOKEN;
IF TOKEN≠"""" THEN ERROR("need double quote here");
GTOKEN;
WHILE TOKEN≠"""" DO BEGIN S←S&TOKEN&" "; GTOKEN; END;
FNAME←S;
END;
WORD_READ(")");
GTOKEN(FALSE);
IF NOT FINAL THEN ERROR("This is an incomplete instruction")
ELSE IF EQU(COMMAND,"READ") THEN
$PCODE←$RFORCEPCODE
ELSE IF VAL←RWRIST(COMMAND,VAL,FNAME) THEN
ERROR("ERROR in reading wrist",$WRMSG[VAL]);
END;
ENDC
PROCEDURE SETBASEPROC;
$PCODE←EXPR$1(XSETBAS);
PROCEDURE WRISTPROC;
BEGIN RPTR(SYMBOL) S;
WORD_READ("("); GTOKEN;
IF TOKENPTR=NULL_RECORD OR
SYMBOL:TYPE[TOKENPTR]≠#SC OR
SYMBOL:ACCESS[TOKENPTR]≠#ARRAY
OR ARRAYREC:#DIM[SYMBOL:OBJECT[TOKENPTR]]≠1
THEN ERROR("Need one dimensioned scalar array in WRIST");
S←TOKENPTR; WORD_READ(")");
$PCODE←EXPR$2(XWRIST,SYMBOL:OFFSET[S]);
END;
IFC #GATHER THENC
PRESET_WITH "FX","FY","FZ","MX","MY","MZ","T1","T2","T3","T4","T5","T6","TBL";
STRING ARRAY GATHCODES[0:12];
PROCEDURE GATHERPROC;
BEGIN INTEGER STATUS,I; INTEGER S1;
WORD_READ("("); STATUS←0;
DO BEGIN
GTOKEN;
FOR I←0 STEP 1 UNTIL 12 DO IF EQU(TOKEN,GATHCODES[I]) THEN DONE;
IF I>12 THEN ERROR("Unrecognized code found: ",TOKEN);
STATUS←STATUS LOR ('1 LSH I);
GTOKEN;
END UNTIL TOKEN≠",";
IF TOKEN≠")" THEN ERROR("Need right paren here");
$PCODE←EXPR$2(XGATHER,STATUS);
END;
PROCEDURE GRAPHPROC;
BEGIN
IF $COMPILE≠0 THEN ERROR("GRAPH: can only be called outside a block");
IF GRAPTR=NULL_RECORD THEN ERROR("GRAPH: no data currently available");
BRK_N;
GRAPH(GRAPHREC:DATA[GRAPTR],
GRAPHREC:CTLBITS[GRAPTR],
GRAPHREC:NPNTS[GRAPTR],
GRAPHREC:SIZE[GRAPTR]);
GRAPTR←NULL_RECORD;
END;
ENDC
PROCEDURE SETSTIFFPROC;
BEGIN
RPTR(EXPR$) ARRAY E[1:7];
INTEGER NARGS;
WORD_READ("("); NARGS←0;
DO BEGIN
E[NARGS←NARGS+1]←$$GTSCEXP("argument in SETSTIFF");
GTOKEN;
END UNTIL TOKEN≠"," OR NARGS>6;
IF TOKEN≠")" OR NARGS≠6 THEN ERROR("Need right paren after 6th argument");
E[7]←EXPR$1(XSETSTF);
$PCODE←$AAPPEND(E);
END;
! pdp 10 procedures: readproc,renmproc,writeproc;
IFC #OUTPT THENC
PROCEDURE READPROC(BOOLEAN ECHO(TRUE));
BEGIN
STRING FILE;
$HELP←34;
FILE←"DECLAR.AL"; ! default value;
NOEXPAND←TRUE;
GTOKEN(FALSE);
IF NOT FINAL
THEN BEGIN
STOKEN←TRUE;FILE←NAMEFILE;SEMICOL_READ;
END;
NOEXPAND←FALSE;
READCODE(FILE,ECHO);
END;
PROCEDURE WRITEPROC;
BEGIN "A"
STRING FILE;
INTEGER NELEMENTS,I;
RPTR(SYMBOL)ARRAY ELEMENTS[1:20];
NELEMENTS←0;
$HELP←31;
NOEXPAND←TRUE; ! to let through macro names ;
FILE←$ALFL; ! default values;
GTOKEN(FALSE);
IF NOT FINAL
THEN CASE #TOKEN OF
α
[RES_TYPE]
IF EQU(TOKEN,"INTO") THEN STOKEN←TRUE
ELSE IF ¬EQU(TOKEN,"ALL") THEN ERROR("Can't use "&TOKEN&
" as argument to be saved in a write statement");
[ID_TYPE]
DO α
IF (NELEMENTS←NELEMENTS+1)>21 THEN ERROR("Cant output more than 21 elements in one statement");
ELEMENTS[NELEMENTS]←TOKENPTR;
GTOKEN(FALSE);
IF TOKEN="," THEN GTOKEN
ELSE IF FINAL THEN DONE
ELSE STOKEN←TRUE;
β UNTIL #TOKEN≠ID_TYPE;
ELSE ERROR("Can't write out the value of "&TOKEN)
β;
GTOKEN(FALSE);
IF NOT FINAL
THEN IF ¬EQU(TOKEN,"INTO") THEN
ERROR("Need INTO here before putting in file name, but you have got "&token)
ELSE FILE←NAMEFILE;
IF NELEMENTS=0 THEN WRITECODE(FILE,NULL_RECORD)
ELSE FOR I←1 STEP 1 UNTIL NELEMENTS DO WRITECODE(FILE,ELEMENTS[I]);
NOEXPAND ← FALSE;
END "A";
ENDC
! pdp 10 procedures: notavailproc,display procedures,message procedures;
PROCEDURE NOTAVAILPROC;
BEGIN
PRINT(TOKEN & " " &#VERSION);
OUTSTR("Will flush this statement"&crlf);
DO GTOKEN(FALSE) UNTIL FINAL;
END;
IFC #DISPL THENC
PROCEDURE REDISPLAYPROC;
BEGIN
SEMICOL_READ;
$ALLOW←0;
TDISPLAY←0;
MDISPLAY←TABLE_DISPLAY;
DISPLAY_LIST←NULL_RECORD;
$SCLST←NULL;
END;
PROCEDURE NODISPLAYPROC;
BEGIN
! SUPPRESS DISPLAY;
SEMICOL_READ;
NDISPLAY←TRUE;
MDISPLAY←NO_DISPLAY;
DISPLAY_LIST←NULL_RECORD;
END;
PROCEDURE DISPLAYPROC;
BEGIN
INTEGER TT;
NOEXPAND ← TRUE;
GTOKEN;
IF TOKENPTR ≠ NULL_RECORD
THEN DPYELM(CVSSYM(TOKENPTR))
ELSE BEGIN
FOR TT←#MIN STEP 1 UNTIL #MAX DO
IF EQU(TOKEN,$DTYPE[TT]) OR EQU(TOKEN,$DTYPE[TT]&"S") THEN DONE;
IF TT≤#MAX THEN $DISPLAYLIST[TT]←NULL
ELSE ERROR("No such data type or identifier: "&TOKEN&CRLF);
SEMICOL_READ;
MDISPLAY←TYPE_DISPLAY;
TDISPLAY←TT;
END;
NOEXPAND ← FALSE;
END;
PROCEDURE SHOWPROC;
BEGIN
RPTR(SYMBOL_LIST)SL1,SL2;
NOEXPAND ← TRUE;
SL1←SL2←NEW_RECORD(SYMBOL_LIST);
DO BEGIN
GTOKEN;
IF TOKENPTR=NULL_RECORD
THEN ERROR("SHOW: Need a macro, procedure or variable name after SHOW");
SYMBOL_LIST:NEXT[SL2]←SL2←NEW_RECORD(SYMBOL_LIST);
SYMBOL_LIST:PTR[SL2]←TOKENPTR;
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL THEN ERROR("Need a comma to separate arguments");
END UNTIL FINAL;
NOEXPAND ← FALSE;
MDISPLAY←SYMBOL_DISPLAY;
DISPLAY_LIST←SYMBOL_LIST:NEXT[SL1];
END;
ENDC
PROCEDURE READMESSPROC;
BEGIN
SEMICOL_READ;
PUSHDEVSTACK;
DEVICE←MESSAGE_X;
END;
PROCEDURE STOPMESSPROC;
BEGIN
SEMICOL_READ;
$CLNE←$CLINR←NULL;
POPDEVSTACK;
END;
! debugging procedures: bailcall, ddtcall;
IFC #DEBUG THENC
PROCEDURE BAILCALL;
BEGIN
GTOKEN(FALSE);
IF TOKEN="("
THEN BEGIN
INTEGER BRCHAR, COUNT;
COUNT←1;
DO BEGIN
IF (BRCHAR←READTILL("()"))="(" THEN COUNT←COUNT+1
ELSE COUNT←COUNT-1;
!!QUERY←!!QUERY&TOKEN&BRCHAR;
END UNTIL COUNT=0;
!!QUERY←!!QUERY[1 TO ∞-1];
END
ELSE STOKEN←TRUE;
BRK_N;
BAIL;
END;
PROCEDURE QBAILCALL;
begin integer chn, count, brchar, eof, all;
open(chn ← getchan, "DSK", 1, 2, 0, count, brchar, eof);
if ¬eof then
begin
lookup(chn, "QUERY.TXT", eof);
count ← 1000; setbreak(all ← getbreak, ff, null, "IS");
if ¬eof then __query ← input(chn, all);
end;
outstr("!!query ← """ & __query & """" & crlf);
release(chn); relbreak(all);
bail;
end;
INTEGER !!i1,!!i2,!!i3,!!i4,!!i5,!!i6;
RANY !!r1,!!r2,!!r3,!!r4,!!r5,!!r6;
PROCEDURE DINIT;
BEGIN !!i1←!!i2←!!i3←!!i4←!!i5←!!i6←0;
!!r1←!!r2←!!r3←!!r4←!!r5←!!r6←null_record;
END;
REQUIRE DINIT INITIALIZATION;
ENDC
PROCEDURE DDTCALL;
$PCODE←$DDTPCODE;
! beginproc,endproc,ifproc,forproc,whileproc,doproc;
RECURSIVE PROCEDURE BEGINPROC;
BEGIN
RPTR(EXPR$)PBEGIN,PBEGIN2;
RPTR(BLOCKREC)B;
INTEGER TMPOFF;
$COMPILE←$COMPILE+1;
$LEVEL←$LEVEL+1;
TMPOFF←$TMPOFF;
B←NEW_RECORD(BLOCKREC);
BLOCKREC:NEXT[B]←CURBLOCK;
CURBLOCK←B;
PBEGIN←NULL!RECORD;
DO BEGIN
PBEGIN2←PARSE;
PBEGIN←$APPEND(PBEGIN,PBEGIN2);
GTOKEN;
IF TOKEN≠";" AND NOT EQU(TOKEN,"END")
THEN ERROR("Need semicolon to separate statements");
END UNTIL EQU(TOKEN,"END");
$PCODE←$APPEND(PBEGIN,$KVARPCODE(BLOCKREC:#ARGS[CURBLOCK]));
CURBLOCK←BLOCKREC:NEXT[CURBLOCK];
$TMPOFF←TMPOFF;
$LEVEL←$LEVEL-1;
$COMPILE←$COMPILE-1;
END;
PROCEDURE ENDPROC;
BEGIN
IF $COMPILE=0 THEN ERROR("Encountered END as a statement.... strange");
STOKEN←TRUE;
$PCODE←NULL_RECORD;
END;
RECURSIVE PROCEDURE IFPROC;
BEGIN
RPTR(EXPR$)COND,A,B;
$COMPILE←$COMPILE+1;
COND←$$GTSCEXP("condition part of IF statement");
WORD_READ("THEN");
A←PARSE;
GTOKEN;
B←NULL_RECORD;
IF EQU(TOKEN,"ELSE") THEN B←PARSE
ELSE IF TOKEN=";" OR EQU (TOKEN, "END") THEN STOKEN←TRUE
ELSE ERROR("Only ELSE or ; allowed after then part");
$COMPILE←$COMPILE-1;
$PCODE←$IFPCODE(COND,A,B)
END;
RECURSIVE PROCEDURE FORPROC;
BEGIN
RPTR(SYMBOL)S;
RPTR(EXPR$)LB,UB,STE,STATE;
$COMPILE←$COMPILE+1;
GTOKEN;
IF TOKENINDEX≠#SC THEN ERROR("Need scalar for FOR scatement");
S←TOKENPTR;
WORD_READ("←");
LB←$$GTSCEXP("FOR statement");
WORD_READ("STEP");
STE←$$GTSCEXP("FOR statement");
WORD_READ("UNTIL");
UB←$$GTSCEXP("FOR statement");
WORD_READ("DO");
STATE←PARSE;
$PCODE←$FORPCODE(S,LB,STE,UB,STATE);
$COMPILE←$COMPILE-1;
END;
RECURSIVE PROCEDURE WHILEPROC;
BEGIN
RPTR(EXPR$)COND,S;
$COMPILE←$COMPILE+1;
COND←$$GTSCEXP("condition part of WHILE statement");
WORD_READ("DO");
S←PARSE;
$COMPILE←$COMPILE-1;
$PCODE←$WHILEPCODE(COND,S);
END;
RECURSIVE PROCEDURE DOPROC;
BEGIN
RPTR(EXPR$)S,COND;
$COMPILE←$COMPILE+1;
S←PARSE;
WORD_READ("UNTIL");
COND←$$GTSCEXP("UNTIL part of DO statement");
$PCODE←$DOPCODE(S,COND);
$COMPILE←$COMPILE-1;
END;
! parse;
define tokencodes "[][]" =[
ZZ("↓", DOWNARROW_X, PF_XX)
ZZ("∧", and_X, BFACT_XX)
ZZ("¬", not_X, PF_XX)
ZZ("⊗", xor_X, BEFACT_XX)
ZZ("→", frontarrow_X, FACTOR_XX)
ZZ("≠", sne_X, BTERM_XX)
ZZ("≤", sle_X, BTERM_XX)
ZZ("≥", sge_X, BTERM_XX)
ZZ("≡", eqv_X, EXP_XX)
ZZ("∨", or_X, BEFACT_XX)
ZZ("$", DOLLAR_X, PF_XX)
ZZ("α", ALPHA_X, PF_XX)
ZZ(["("], LPAREN_X, PF_XX)
ZZ("*", times_X, TERM_XX)
ZZ("+", Plus_X, AEXP_XX)
ZZ("-", minus_X, AEXP_XX)
ZZ(".", vdot_X, TERM_XX)
ZZ("/", sdiv_X, TERM_XX)
ZZ("<", slt_X, BTERM_XX)
ZZ("=", seq_X, BTERM_XX)
ZZ(">", sgt_X, BTERM_XX)
XX(TRUE, ABORT, PRINTPROC(EXPR$1(XABORT)))
ZZ("ACOS", acos_X, PF_XX)
XX(TRUE, AFFIX, AFFIXPROC)
XX(TRUE, ALL, NOTAVAILPROC)
ZZ("AND", aand_X, BFACT_XX)
XX(TRUE, ARRAY, NOTAVAILPROC)
ZZ("ASIN", asin_X, PF_XX)
ZZ("ATAN2", atan2_X, PF_XX)
ZZ("AXIS", axis_X, PF_XX)
XX(#DEBUG, BAIL, BAILCALL)
XX(TRUE, BEGIN, BEGINPROC)
XX(#MOVE, BY, DEFLT("BY"))
XX(#MOVE, CENTER, CENTERPROC)
XX(TRUE, CLOSE, CLOSEPROC)
XX(TRUE, CLOSE_FILES, FCLPROC)
XX(TRUE, COMMENT, [READTO(";")])
ZZ("CONSTRUCT", construct_X, PF_XX)
XX(TRUE, COPY, COPYPROC)
ZZ("COS", cos_X, PF_XX)
XX(TRUE, DDT, DDTCALL)
XX(TRUE, DEFINE, DEFINEPROC)
XX(TRUE, DELETE, DELETEPROC)
XX(#DISPL, DISPLAY, DISPLAYPROC)
ZZ("DIV", div_X, TERM_XX)
XX(TRUE, DO, DOPROC)
XX(#MOVE, DRIVE, DRIVEPROC)
XX(TRUE, ECHOOFF, [FILEPRINT←FALSE])
XX(TRUE, ECHOON, [FILEPRINT←TRUE])
XX(TRUE, EDIT, EDITPROC("EDIT"))
XX(TRUE, END, ENDPROC)
ZZ("EQV", eeqv_X, EXP_XX)
ZZ("EVAL", EVAL_X, PF_XX)
XX(TRUE, EXIT, EXITPROC)
ZZ("EXP", exp_X, PF_XX)
XX(FALSE, FCONSTRUCT, FCONSTRUCTPROC)
XX(TRUE, FOR, FORPROC)
XXZZ(TRUE, FRAME, DECLPROC(#FR), FRAME_X, PF_XX)
XX(not #nofunct, FUNCTION, FUNCTPROC)
XX(#GATHER, GATHER, GATHERPROC)
XX(#GATHER, GRAPH, GRAPHPROC)
XX(#HELP, HELP, HELPREQUEST)
XX(TRUE, IF, IFPROC)
ZZ("INT", int_X, PF_XX)
XX(TRUE, INTO, NOTAVAILPROC)
ZZ("INV", rinv_X, PF_XX)
ZZ("LOG", log_X, PF_XX)
ZZ("MAX", max_X, TERM_XX)
XX(TRUE, MERGE, NOTAVAILPROC)
ZZ("MIN", min_X, TERM_XX)
ZZ("MOD", mod_X, TERM_XX)
XX(#MOVE, MOVE, MOVEPROC)
XX(#MOVE, MOVEX, AXMOVPROC)
XX(#MOVE, MOVEY, AXMOVPROC)
XX(#MOVE, MOVEZ, AXMOVPROC)
XX(#DISPL, NODISPLAY, NODISPLAYPROC)
XX(#DISPL, NOUPDATE, [$ALLOW←$ALLOW+1])
XX(#MOVE, OPEN, OPCLPROC(TOKEN))
ZZ("OR", oor_X, BEFACT_XX)
ZZ("ORIENT", orient_X, PF_XX)
XX(#MOVE, PARK, PARKINGPROC)
ZZ("POS", pos_X, PF_XX)
XX(#DEBUG, PPCODE, #PPCODE←TRUE)
XX(TRUE, PRINT, PRINTPROC)
XX(TRUE, PROCEDURE, PROCDECLPROC)
XX(TRUE, PROMPT, PRINTPROC(EXPR$1(XPROMPT)))
XX(#DEBUG, QBAIL, QBAILCALL)
XX(TRUE, QDELETE, DELETEPROC(TRUE))
XX(#OUTPT, QREAD, READPROC(FALSE))
XX(#OUTPT, READ, READPROC)
XX(TRUE, READMESSAGE, READMESSPROC)
XX(#WRIST, READWRIST, READWRISTPROC)
XX(#DISPL, REDISPLAY, REDISPLAYPROC)
XX(TRUE, REFERENCE, NOTAVAILPROC)
ZZ("REL", rel_X, FACTOR_XX)
XX(TRUE, RENAME, EDITPROC("RENAME"))
XX(TRUE, RETURN, RETURNPROC)
! ZZ("ROT", ROT_X, PF_XX) ;
XXZZ(TRUE, ROT, DECLPROC(#RT), ROT_X, PF_XX)
XX(TRUE, SCALAR, DECLPROC(#SC))
XX(TRUE, SETBASE, SETBASEPROC)
XX(TRUE, SETSTIFF, SETSTIFFPROC)
XX(TRUE, SHOW, SHOWPROC)
ZZ("SIN", sin_X, PF_XX)
ZZ("SQRT", sqrt_X, PF_XX)
XX(TRUE, STOPMESSAGE, STOPMESSPROC)
XX(TRUE, SUBTREE, NOTAVAILPROC)
ZZ("TAN", tan_X, PF_XX)
XX(#MOVE, TO, DEFLT("TO"))
XXZZ(TRUE, TRANS, DECLPROC(#TR), TRANS_X, PF_XX)
XX(TRUE, UNFIX, UNFIXPROC)
ZZ("UNIT", uvect_X, PF_XX)
XX(#DISPL, UPDATE, [$ALLOW←$ALLOW-1])
XX(TRUE, VALUE, NOTAVAILPROC)
XXZZ(TRUE, VECTOR, DECLPROC(#VT), VECTOR_X, PF_XX)
XX(TRUE, VT05_OFF, [$PCODE←EXPR$2(XDISVT05,1)])
XX(TRUE, VT05_ON, [$PCODE←EXPR$2(XDISVT05,0)])
XX(TRUE, WHILE, WHILEPROC)
XX(TRUE, WRIST, WRISTPROC)
XX(#OUTPT, WRITE, WRITEPROC)
ZZ("WRT", wrt_X, FACTOR_XX)
ZZ("XOR", xxor_X, BEFACT_XX)
ZZ("↑", stos_X, FACTOR_XX)
ZZ("|", MAGNITUDE_X, PF_XX)
];
! prepare to count number of reserved tokens ;
define res_count = 0;
redefine zz(arg1,arg2,arg3)"[][]"=[redefine res_count=res_count+1;];
redefine xxzz(#flag,str,oper,arg1,arg2)"[][]"=[redefine res_count=res_count+1;];
redefine xx(#flag, str, oper)"[][]"=[redefine res_count=res_count+1;];
! ****** now actually go and count them ****** ;
tokencodes;
! prepare to set up a string array of reserved tokens ;
redefine xx(#flag,str,oper)"[][]" = ["str", ];
redefine xxzz(#flag,str,oper,arg1,arg2)"[][]"=["str",];
redefine zz(arg1,arg2,arg3)"[][]"=[arg1,];
! ****** now go and set up the string array of reserved tokens **** ;
! array containing all the reserved words and operators;
preset_array( rescode , tokencodes , string , 1 , res_count);
! now prepare to set up integer array of codes ;
define xx_count=0;
redefine xx(#flag,str,oper)"[][]"=[
redefine xx_count=xx_count+1;
xx_count*(ROT_X+1)*#DTYPE, ];
redefine zz(arg1,arg2,arg3)= [arg2*#dtype+arg3,];
redefine xxzz(#flag,str,oper,arg1,arg2)"[][]"=[
redefine xx_count=xx_count+1;
(xx_count*(rot_x+1)+arg1)*#dtype+arg2, ];
! ***** now set up the array ***** ;
preset_array(tcodes, tokencodes, integer, 1, res_count);
INTERNAL INTEGER PROCEDURE DECSTR(string VAL);
BEGIN INTEGER L,M,U,I1,I2; STRING S1,S2;
L←1; U←res_count;
DO begin M←(U+L)/2;
IF EQU(S1←rescode[M],S2←val) THEN
begin res_class←TCODES[M] DIV( (ROT_X+1)*#DTYPE);
tokenclass←tcodeS[m] mod #dtype;
tokenindex← (tcodeS[m] div #dtype) mod (rot_x+1);
RETURN(M);
end
ELSE DO begin I1←LOP(S1); I2←LOP(S2); end until i1≠i2;
if i1>i2 then U←M-1 ELSE L←M+1;
end UNTIL L>U;
res_class←tokenclass←tokenindex←0;
RETURN(0);
END;
INTERNAL RECURSIVE RPTR(EXPR$)PROCEDURE PARSE;
BEGIN "PARSE"
$PCODE←NULL_RECORD;
NOEXPAND←FALSE;
GTOKEN; ! reads first token;
STBEGIN←FALSE;
IF "A"≤ TOKEN ≤"Z" THEN
CASE res_class of
BEGIN "CASE"
redefine xx(#flag, str,oper)"[][]"=[
ifc #flag thenc ; oper elsec ; notavailproc endc];
redefine xxzz(#flag, str,oper,arg1,arg2)"[][]"=[
; oper ];
redefine zz(arg1,arg2,arg3)"[][]"=[];
OTHER
tokencodes
END "CASE"
ELSE IF TOKEN=";" OR TOKEN=NULL THEN
BEGIN IF $COMPILE THEN STOKEN←TRUE END
ELSE IF TOKEN="?" THEN IFC #HELP
THENC HELPREQUEST
ELSEC PRINT(#VERSION) ENDC
ELSE IFC #ARROW THENC
IF TOKEN="↑"
THEN BEGIN $ARROW←$ARROW+20; UPDATE; END
ELSE IF TOKEN="↓"
THEN BEGIN $ARROW←$ARROW-20; UPDATE; END
ELSE IF #TOKEN=INT_TYPE
THEN BEGIN
INTEGER NUM;
NUM←INTSCAN(TOKEN,$BRCHR);
GTOKEN;
IF TOKEN="↓" THEN $ARROW←$ARROW-NUM*20
ELSE IF TOKEN="↑" THEN $ARROW←$ARROW+NUM*20
ELSE ERROR($SYNMSG[32],NULL);
UPDATE;
END
ELSE ENDC
BEGIN $HELP←8; ERROR($SYNMSG[31],NULL); END;
IF NOT $COMPILE
THEN BEGIN "interpret it"
$ALLOW←$ALLOW+1;
IFC #DEBUG THENC
IF #PPCODE AND $PCODE THEN
BEGIN BRK_N; PPCODE($PCODE); #PPCODE←FALSE; END;
ENDC
IF $PCODE THEN $EXECUTE($PCODE);
$PCODE←NULL_RECORD;
$ALLOW←$ALLOW-1;
IFC #DISPL THENC UPDATE; ENDC
END;
RETURN($PCODE);
END "PARSE";
! main program;
INTEGER HOUR; STRING $HOUR;
SIMPLE INTEGER PROCEDURE GETHOUR;
RETURN( CALL(0,"TIMER") DIV 216000);
IFC #DISPL THENC INIDPY;ENDC
HOUR←GETHOUR;
IF HOUR < 12 THEN $HOUR←"Morning" ELSE IF HOUR < 17 THEN $HOUR←"Afternoon"
ELSE $HOUR←"Evening";
BRK_N;
PRINT("Hello..."&$USERNAME&"...Good "&$HOUR&" and welcome to POINTY Version 3
************ THIS IS A NEW VERSION OF POINTY USING THE AL RUNTIME SYSTEM *****
************ It allows control structures, procedures, arrays,etc........ ****
************ IF THERE IS ANY TROUBLE YOU CAN GET THE OLD SYSTEM BY DOING *****
************ a DO PNTOLD[PNT,HE] instead of DO POINTY[PNT,HE] ****************
************ and please send MSM a message ***********************************
");
IFC #OUTPT THENC
BACKUP; $HOUR←INCHSL(HOUR);
IF $HOUR[∞ FOR 1]≠"Q" THEN TTYSAVE; STOKEN←FALSE; ENDC
! allows opening a file to save ;
IFC #DISPL THENC ARRCLR($DISPLAYLIST,NULL); UPDATE;ENDC
intmap(15,esc_I,0); ! set mapping for interrupt handler;
enable(15); ! enable the interrupt handler;
$ESC_I←FALSE;
WHILE TRUE DO
BEGIN
$COMPILE←0; ! set interpreter mode;
$LEVEL←0; ! indicate it is top level ;
$TMPOFF←$SYMOFF;
CURPROC←NULL_RECORD;
CURBLOCK←NULL_RECORD;
STBEGIN←TRUE; ! waiting for a new command;
PARSE; ! parses the instruction;
CHKESC_I;
MAINL: STOKEN←FALSE;
IFC #WRIST THENC IF WSTPTR THEN RWRIST("READ"); ENDC
END;
DONEPOINTY:
BRK_N; ! clear the screen and normalize it;
HOUR←GETHOUR;
IF HOUR<5 THEN $HOUR←"please get some sleep, you've been working late"
ELSE IF HOUR <15 THEN $HOUR←"have a nice day"
ELSE IF HOUR <20 THEN $HOUR←"have a nice evening"
ELSE $HOUR←"good night, and pleasant dreams";
PRINT("Bye,bye, ..."&$USERNAME&"... "&$HOUR,CRLF);
LODED("dea elf"&CRLF&CRLF); ! to avoid forgetting to deassign;